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

ada-examples-4-10-branch
Last change on this file since c53f12b was c53f12b, checked in by Joel Sherrill <joel.sherrill@…>, on Feb 2, 2011 at 7:08:06 PM

2011-02-02 Joel Sherrill <joel.sherrill@…>

  • commands.adb, commands.ads, rtems_shell.ads, shell.adb: Add getopt_r Package and example command.
  • command_line_arguments.adb, command_line_arguments.ads, getopt_r.adb, getopt_r.ads: New files.
  • Property mode set to 100644
File size: 6.7 KB
Line 
1--
2--                            REENTRANT GETOPT
3--                                 BODY
4-- $Id$
5--
6--  Based upon getopt by Nasser Abbasi.
7--  modifications to support reentrancy by Joel Sherrill.
8--
9--  Copyright (C) 1998 Nasser Abbasi <nabbasi@pacbell.net>
10--  Copyright (C) 2011 Joel Sherrill <joe.sherrill@oarcorp.com>
11--
12-- This is free software;  you can  redistribute it  and/or modify it under
13-- terms of the  GNU General Public License as published  by the Free Soft-
14-- ware  Foundation;  either version 2,  or (at your option) any later ver-
15-- sion. GETOPT is distributed in the hope that it will be useful, but WITH
16-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY
17-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
18-- for  more details. Free Software Foundation,  59 Temple Place - Suite
19-- 330,  Boston, MA 02111-1307, USA.
20--
21-- As a special exception,  if other files  instantiate  generics from this
22-- unit, or you link  this unit with other files  to produce an executable,
23-- this  unit  does not  by itself cause  the resulting  executable  to  be
24-- covered  by the  GNU  General  Public  License.  This exception does not
25-- however invalidate  any other reasons why  the executable file  might be
26-- covered by the  GNU Public License.
27--
28------------------------------------------------------------------------------
29--
30-- change history:
31--
32-- name         changes
33-- ----------   --------------------------------------------------------------
34-- NMA021899    created
35-- NMA030299    Changed header to make it modified GPL
36--
37-- description:
38--
39-- This package is an Ada implementation of getopt() as specified by the
40-- document "The Single UNIX Specification, Version 2", Copyright 1997 The
41-- Open Group
42--
43-- This describes the items involveed using example
44--
45--
46--         curopt
47--           |
48--           V
49-- "-f foo -dbc -k"
50--  ^
51--  |
52-- optind
53--
54-- optind is position (index) that tells which command line argument is
55-- being processed now.
56-- curopt tells which optchar is being processed within one command line
57-- argument. This is needed only if more that one optchar are stuck
58-- togother in one argument with no space, as in -df where both d and f
59-- are valid optchar and d takes no optarg.
60--
61-- Compiler used: GCC 4.5.2 targeting i386-rtems4.10
62-- Platform:      Fedora 14/x86_64
63--
64
65with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
66with Ada.Text_Io; use Ada.Text_Io;
67with Interfaces.C;          use Interfaces.C;
68with Interfaces.C.Pointers;
69with Interfaces.C.Strings;  use Interfaces.C.Strings;
70
71package body Getopt_R is
72
73   ----------------
74   -- Initialize --
75   ----------------
76
77   procedure Initialize (
78     R     : Reentrant_Ptr;
79     Argc  : Argument_Count_Type;
80     Argv  : Argument_Vector_Type
81   ) is
82   begin
83      R.Optind := 2;
84      R.Optopt := ' ';
85      R.Opterr := 1;
86      R.Curopt := 2;
87      R.Argc := Argc;
88      R.ArgV := Argv;
89   end Initialize;
90
91   ------------
92   -- Getopt --
93   ------------
94
95   function Getopt (
96     R : Reentrant_Ptr;
97     Optstring : String
98   ) return Integer is
99     Arg       : Unbounded_String;
100     Arguments : Argument_Array(1 .. R.Argc);
101   begin
102
103
104      if (R.Argc = 0  or else
105          R.optind > R.Argc) then
106         return -1;
107      end if;
108
109      Arguments := Argument_Vector_Package.Value (R.ArgV, R.ArgC);
110
111      Arg := To_Unbounded_String (Value(Arguments (R.optind)));
112      if Element (Arg, 1) /= '-' then
113         return -1;
114      end if;
115     
116      if (Length(Arg) = 1) then
117         return -1;
118      end if;
119
120      --  according to The Single UNIX  Specification, Version 2, if "--"
121      --  is found, return -1 after  ++optind.
122      if Element (Arg, 2) = '-' then
123         R.Optind := R.Optind + 1;
124         return -1;
125      end if;
126
127      --  if we get here, the command argument has "-X"
128      for I in Optstring'Range loop
129         Arg := To_Unbounded_String (Value(Arguments (R.optind)));
130         if (Optstring (I) = Element (Arg, R.Curopt)) then
131            if (I < Optstring'Length) then
132               if (Optstring (I + 1) = ':') then
133
134                  --  see if optarg stuck to optchar
135                  if ( Length (Arg) -  R.Curopt > 0) then
136                     R.Optarg  := To_Unbounded_String
137                        (Slice (Arg, R.Curopt + 1, Length (Arg)));
138                     R.Curopt := R.Curopt + 1;
139                     R.Optind := R.Optind + 1;
140                     return character'Pos (Optstring (I));
141                  end if;
142
143                  --  see if optarg on separate argument
144                  if (R.Optind < R.Argc) then
145                     R.Curopt := 2;
146                     R.Optind  := R.Optind + 1;
147                     R.Optarg  := To_Unbounded_String
148                                  (Value (Arguments (R.Optind)));
149                     R.Optind  := R.optind + 1;
150                     return character'Pos (Optstring (I));
151                  else
152                     R.Optind := R.Optind + 1;
153                     R.Optopt := Optstring (I);
154
155                     if (R.Opterr = 1  and
156                         Optstring (Optstring'First) /= ':') then
157                        Put_Line (Standard_Error,
158                                 "Argument expected for the -"&
159                                 Optstring (I .. I) & " option");
160                     end if;
161
162                     if (Optstring (Optstring'First) = ':') then
163                        return Character'Pos (':');
164                     else
165                        return  Character'Pos ('?');
166                     end if;
167                  end if;
168               else  -- current optchar matches and has no arg option
169                  if (R.Curopt < Length (Arg)) then
170                     R.Curopt := R.Curopt + 1;
171                  else
172                     R.Curopt := 2;
173                     R.Optind := R.Optind + 1;
174                  end if;
175                  return character'Pos (Optstring (I));
176               end if;
177            else -- last char in optstring, can't have argument
178               if (R.Curopt < Length (Arg)) then
179                  R.Curopt := R.Curopt + 1;
180               else
181                  R.Curopt := 2;
182                  R.Optind := R.Optind + 1;
183               end if;
184               return character'Pos (Optstring (I));
185            end if;
186         end if;
187      end loop;
188
189      Arg := To_Unbounded_String (Value(Arguments (R.optind)));
190      R.Optopt := Element (Arg, R.Curopt);
191      if (R.Curopt < Length (Arg)) then
192         R.Curopt := R.Curopt + 1;
193      else
194         R.Curopt := 2;
195         R.Optind := R.Optind + 1;
196      end if;
197
198      --  we get here if current command argument not found in optstring
199      return character'Pos ('?');
200
201   end Getopt;
202
203begin
204  Null;
205end Getopt_R;
Note: See TracBrowser for help on using the repository browser.