source: ada-examples/shell/getopt_r.adb @ c53f12b

--
--                            REENTRANT GETOPT
--                                 BODY
-- $Id$
--
--  Based upon getopt by Nasser Abbasi.
--  modifications to support reentrancy by Joel Sherrill.
--
--  Copyright (C) 1998 Nasser Abbasi <nabbasi@pacbell.net>
--  Copyright (C) 2011 Joel Sherrill <joe.sherrill@oarcorp.com>
--
-- This 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. GETOPT 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. Free Software Foundation,  59 Temple Place - Suite
-- 330,  Boston, MA 02111-1307, 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.
--
------------------------------------------------------------------------------
--
-- change history:
--
-- name         changes
-- ----------   --------------------------------------------------------------
-- NMA021899    created
-- NMA030299    Changed header to make it modified GPL
--
-- description:
--
-- This package is an Ada implementation of getopt() as specified by the
-- document "The Single UNIX Specification, Version 2", Copyright 1997 The
-- Open Group
--
-- This describes the items involveed using example
--
--
--         curopt
--           |
--           V
-- "-f foo -dbc -k"
--  ^
--  |
-- optind
--
-- optind is position (index) that tells which command line argument is
-- being processed now.
-- curopt tells which optchar is being processed within one command line
-- argument. This is needed only if more that one optchar are stuck
-- togother in one argument with no space, as in -df where both d and f
-- are valid optchar and d takes no optarg.
--
-- Compiler used: GCC 4.5.2 targeting i386-rtems4.10
-- Platform:      Fedora 14/x86_64
--

with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Text_Io; use Ada.Text_Io;
with Interfaces.C;          use Interfaces.C;
with Interfaces.C.Pointers;
with Interfaces.C.Strings;  use Interfaces.C.Strings;

package body Getopt_R is

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize (
     R     : Reentrant_Ptr;
     Argc  : Argument_Count_Type;
     Argv  : Argument_Vector_Type
   ) is
   begin
      R.Optind := 2;
      R.Optopt := ' ';
      R.Opterr := 1;
      R.Curopt := 2;
      R.Argc := Argc;
      R.ArgV := Argv;
   end Initialize;

   ------------
   -- Getopt --
   ------------

   function Getopt (
     R : Reentrant_Ptr;
     Optstring : String
   ) return Integer is
     Arg       : Unbounded_String;
     Arguments : Argument_Array(1 .. R.Argc);
   begin


      if (R.Argc = 0  or else
          R.optind > R.Argc) then
         return -1;
      end if;

      Arguments := Argument_Vector_Package.Value (R.ArgV, R.ArgC);

      Arg := To_Unbounded_String (Value(Arguments (R.optind)));
      if Element (Arg, 1) /= '-' then
         return -1;
      end if;
      
      if (Length(Arg) = 1) then
         return -1;
      end if;

      --  according to The Single UNIX  Specification, Version 2, if "--"
      --  is found, return -1 after  ++optind.
      if Element (Arg, 2) = '-' then
         R.Optind := R.Optind + 1;
         return -1;
      end if;

      --  if we get here, the command argument has "-X"
      for I in Optstring'Range loop
         Arg := To_Unbounded_String (Value(Arguments (R.optind)));
         if (Optstring (I) = Element (Arg, R.Curopt)) then
            if (I < Optstring'Length) then
               if (Optstring (I + 1) = ':') then

                  --  see if optarg stuck to optchar
                  if ( Length (Arg) -  R.Curopt > 0) then
                     R.Optarg  := To_Unbounded_String 
                        (Slice (Arg, R.Curopt + 1, Length (Arg)));
                     R.Curopt := R.Curopt + 1;
                     R.Optind := R.Optind + 1;
                     return character'Pos (Optstring (I));
                  end if;

                  --  see if optarg on separate argument
                  if (R.Optind < R.Argc) then
                     R.Curopt := 2;
                     R.Optind  := R.Optind + 1;
                     R.Optarg  := To_Unbounded_String
                                  (Value (Arguments (R.Optind)));
                     R.Optind  := R.optind + 1;
                     return character'Pos (Optstring (I));
                  else
                     R.Optind := R.Optind + 1;
                     R.Optopt := Optstring (I);

                     if (R.Opterr = 1  and
                         Optstring (Optstring'First) /= ':') then
                        Put_Line (Standard_Error,
                                 "Argument expected for the -"&
                                 Optstring (I .. I) & " option");
                     end if;

                     if (Optstring (Optstring'First) = ':') then
                        return Character'Pos (':');
                     else
                        return  Character'Pos ('?');
                     end if;
                  end if;
               else  -- current optchar matches and has no arg option
                  if (R.Curopt < Length (Arg)) then
                     R.Curopt := R.Curopt + 1;
                  else
                     R.Curopt := 2;
                     R.Optind := R.Optind + 1;
                  end if;
                  return character'Pos (Optstring (I));
               end if;
            else -- last char in optstring, can't have argument
               if (R.Curopt < Length (Arg)) then
                  R.Curopt := R.Curopt + 1;
               else
                  R.Curopt := 2;
                  R.Optind := R.Optind + 1;
               end if;
               return character'Pos (Optstring (I));
            end if;
         end if;
      end loop;

      Arg := To_Unbounded_String (Value(Arguments (R.optind)));
      R.Optopt := Element (Arg, R.Curopt);
      if (R.Curopt < Length (Arg)) then
         R.Curopt := R.Curopt + 1;
      else
         R.Curopt := 2;
         R.Optind := R.Optind + 1;
      end if;

      --  we get here if current command argument not found in optstring
      return character'Pos ('?');

   end Getopt;

begin
  Null;
end Getopt_R;