Menu
▾
▴
htoolkit-cvs — HToolkit CVS commit messages
You can subscribe to this list here.
| 2003 |
Jan
(30) |
Feb
(20) |
Mar
(151) |
Apr
(86) |
May
(23) |
Jun
(25) |
Jul
(107) |
Aug
(141) |
Sep
(55) |
Oct
(85) |
Nov
(65) |
Dec
(2) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2004 |
Jan
(22) |
Feb
(18) |
Mar
(3) |
Apr
(16) |
May
(69) |
Jun
(3) |
Jul
(1) |
Aug
(3) |
Sep
(1) |
Oct
|
Nov
(6) |
Dec
(1) |
| 2005 |
Jan
(2) |
Feb
(16) |
Mar
|
Apr
|
May
|
Jun
(47) |
Jul
(1) |
Aug
|
Sep
(6) |
Oct
(4) |
Nov
|
Dec
(34) |
| 2006 |
Jan
(39) |
Feb
|
Mar
(2) |
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
|
Sep
(5) |
Oct
|
Nov
(4) |
Dec
|
| 2007 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(1) |
| 2008 |
Jan
|
Feb
|
Mar
(26) |
Apr
(1) |
May
(1) |
Jun
|
Jul
(5) |
Aug
(2) |
Sep
(8) |
Oct
(8) |
Nov
(22) |
Dec
(30) |
| 2009 |
Jan
(10) |
Feb
(13) |
Mar
(14) |
Apr
(14) |
May
(32) |
Jun
(25) |
Jul
(36) |
Aug
(10) |
Sep
(2) |
Oct
|
Nov
|
Dec
(10) |
| 2010 |
Jan
(9) |
Feb
(4) |
Mar
(2) |
Apr
(1) |
May
(2) |
Jun
(2) |
Jul
(1) |
Aug
(4) |
Sep
|
Oct
(1) |
Nov
|
Dec
|
|
From: <kr_...@us...> - 2003-09-09 13:34:43
|
Update of /cvsroot/htoolkit/port
In directory sc8-pr-cvs1:/tmp/cvs-serv11150
Modified Files:
configure makefile
Log Message:
Turn back to old configure/make scripts
Index: configure
===================================================================
RCS file: /cvsroot/htoolkit/port/configure,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -d -r1.19 -r1.20
*** configure 31 Aug 2003 08:09:00 -0000 1.19
--- configure 9 Sep 2003 13:34:39 -0000 1.20
***************
*** 1,1824 ****
! #! /bin/sh
! # Guess values for system-dependent variables and create Makefiles.
! # Generated by GNU Autoconf 2.57 for HToolkit 1.0.
! #
! # Report bugs to <ka2...@ya...>.
! #
! # Copyright 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002
! # Free Software Foundation, Inc.
! # This configure script is free software; the Free Software Foundation
! # gives unlimited permission to copy, distribute and modify it.
[...3354 lines suppressed...]
! echo "#ifndef _config_h" >> src/include/config.h
! echo "# define ${target}_TARGET" >> src/include/config.h
! echo "#endif" >> src/include/config.h
+ echo "creating package description"
+ echo " - config/port.pkg"
+ echo "Package" > config/port.pkg
+ echo " { name=\"port\"" >> config/port.pkg
+ echo " , auto=True" >> config/port.pkg
+ echo " , import_dirs=[\"\$libdir/imports\"]" >> config/port.pkg
+ echo " , library_dirs=[\"$libdir\" $extralibdirs]" >> config/port.pkg
+ echo " , hs_libraries=[\"HSport\"]" >> config/port.pkg
+ echo " , extra_libraries=[$extralibs]" >> config/port.pkg
+ echo " , package_deps=[]" >> config/port.pkg
+ echo " , include_dirs = [$incdirs]" >> config/port.pkg
+ echo " , c_includes = [\"HsPort.h\"]" >> config/port.pkg
+ echo " }" >> config/port.pkg
echo "done -- type 'make' to build the package."
+ echo ""
Index: makefile
===================================================================
RCS file: /cvsroot/htoolkit/port/makefile,v
retrieving revision 1.40
retrieving revision 1.41
diff -C2 -d -r1.40 -r1.41
*** makefile 3 Sep 2003 17:03:24 -0000 1.40
--- makefile 9 Sep 2003 13:34:39 -0000 1.41
***************
*** 19,23 ****
# system dependent stuff
! -include config.mk
#--------------------------------------------------------------------------
--- 19,23 ----
# system dependent stuff
! -include config/config.mk
#--------------------------------------------------------------------------
***************
*** 44,48 ****
STUBS = Port/Handlers.hs
- GSTSTUBS = GST/Handlers.c
CSRCS = Window.c Util.c Bitmap.c Button.c CheckBox.c EditBox.c \
--- 44,47 ----
***************
*** 58,62 ****
# package description
! PKG = $(MAIN).pkg
#--------------------------------------------------------------------------
--- 57,61 ----
# package description
! PKG = config/$(MAIN).pkg
#--------------------------------------------------------------------------
***************
*** 88,92 ****
HC-OPTIONS = -O2
! CC-OPTIONS = -O2 -Wall $(CCOPTIONS)
ifdef HDOCHTML
--- 87,91 ----
HC-OPTIONS = -O2
! CC-OPTIONS = -O2
ifdef HDOCHTML
***************
*** 113,131 ****
# main, object files, dependencies and hi files
! HSLIB = $(BUILDDIR)/libHS$(MAIN).a
! GSTLIB = $(BUILDDIR)/libGST$(MAIN).so
MAINOBJ = HS$(MAIN).o
HOBJS = $(patsubst %.hs,$(HOUTDIR)/%.o, $(HSRCS))
! HDEPS = $(patsubst %.hs,$(HOUTDIR)/%.d, $(HSRCS))
! COBJS = $(patsubst %.c,$(COUTDIR)/%.c.o, $(CSRCS))
! CLOBJS = $(patsubst %.c,$(COUTDIR)/%.c.lo, $(CSRCS))
! CDEPS = $(patsubst %.c,$(COUTDIR)/%.c.d, $(CSRCS))
STUBOBJS = $(patsubst %.hs,$(HOUTDIR)/%.o, $(STUBS))
STUBINCS = $(patsubst %.hs,$(HOUTDIR)/%_stub.h, $(STUBS))
STUBSTUBOBJS= $(patsubst %.hs,$(HOUTDIR)/%_stub.o, $(STUBS))
! GSTSTUBOBJS = $(patsubst %.c,$(COUTDIR)/%_stub.o, $(GSTSTUBS))
#--------------------------------------------------------------------------
--- 112,128 ----
# main, object files, dependencies and hi files
! MAINLIB = $(BUILDDIR)/libHS$(MAIN).a
MAINOBJ = HS$(MAIN).o
HOBJS = $(patsubst %.hs,$(HOUTDIR)/%.o, $(HSRCS))
! HDEPS = $(patsubst %.hs,$(HOUTDIR)/%.d, $(HSRCS))
! COBJS = $(patsubst %.c,$(COUTDIR)/%.c.o, $(CSRCS))
! CDEPS = $(patsubst %.c,$(COUTDIR)/%.c.d, $(CSRCS))
STUBOBJS = $(patsubst %.hs,$(HOUTDIR)/%.o, $(STUBS))
STUBINCS = $(patsubst %.hs,$(HOUTDIR)/%_stub.h, $(STUBS))
STUBSTUBOBJS= $(patsubst %.hs,$(HOUTDIR)/%_stub.o, $(STUBS))
!
#--------------------------------------------------------------------------
***************
*** 134,152 ****
# The main targets
! .PHONY: all release
all: release doc
! TARGETLIBS=
! ifeq "$(GHCDISABLED)" "NO"
! TARGETLIBS += $(HSLIB)
! endif
! ifeq "$(GSTDISABLED)" "NO"
! TARGETLIBS += $(GSTLIB)
! endif
!
! release: $(TARGETLIBS)
! install: $(HSLIB) $(PKG)
install -d $(LIBDIR)/imports/Graphics/UI/Port
install -d $(LIBDIR)/include/port
--- 131,141 ----
# The main targets
! .PHONY: all release
all: release doc
! release: $(MAINLIB)
! install: $(MAINLIB) $(PKG)
install -d $(LIBDIR)/imports/Graphics/UI/Port
install -d $(LIBDIR)/include/port
***************
*** 155,159 ****
install -m 644 $(HOUTDIR)/*.hi $(LIBDIR)/imports/Graphics/UI
install -m 644 $(HOUTDIR)/Port/*.hi $(LIBDIR)/imports/Graphics/UI/Port
! install -m 644 $(HSLIB) $(LIBDIR)
install -m 644 src/include/HsPort.h $(LIBDIR)/include
install -m 644 src/include/*.h $(LIBDIR)/include/port
--- 144,148 ----
install -m 644 $(HOUTDIR)/*.hi $(LIBDIR)/imports/Graphics/UI
install -m 644 $(HOUTDIR)/Port/*.hi $(LIBDIR)/imports/Graphics/UI/Port
! install -m 644 $(MAINLIB) $(LIBDIR)
install -m 644 src/include/HsPort.h $(LIBDIR)/include
install -m 644 src/include/*.h $(LIBDIR)/include/port
***************
*** 163,172 ****
install -m 644 doc/*.html doc/*.css doc/*.gif doc/*.haddock $(LIBDIR)/doc/html/port
! $(HSLIB): $(HOBJS) $(COBJS) $(STUBSTUBOBJS)
! $(RM) $(HSLIB)
! $(AR) -r $@ $^
- $(GSTLIB) : $(CLOBJS) $(GSTSTUBOBJS)
- $(LD) $^ -o $@ $(CLIBS)
# create an object file from source files. Note that we also generate
--- 152,159 ----
install -m 644 doc/*.html doc/*.css doc/*.gif doc/*.haddock $(LIBDIR)/doc/html/port
! $(MAINLIB): $(HOBJS) $(COBJS) $(STUBSTUBOBJS)
! $(RM) $(MAINLIB)
! $(AR) -r $@ $^
# create an object file from source files. Note that we also generate
***************
*** 174,178 ****
# by sed to prepend the proper directory to the target and to move it
# into the proper directory (debug or release). The way dependency files
! # are handled was 'discovered' by Tom Tromey, and described by Paul Smith,
# see: "http://www.paulandlesley.org/gmake/autodep.html"
.SUFFIXES: .hs .hi .o .c
--- 161,165 ----
# by sed to prepend the proper directory to the target and to move it
# into the proper directory (debug or release). The way dependency files
! # are handled was 'discovered' by Tom Tromey, and described by Paul Smith,
# see: "http://www.paulandlesley.org/gmake/autodep.html"
.SUFFIXES: .hs .hi .o .c
***************
*** 181,187 ****
$(HC) -o $@ -package-name port -ohi $(BUILDDIR)/Graphics/UI/$(*D)/$(*F).hi -odir $(HOUTDIR)/$(*D) -c $< $(HC-OPTIONS) $($(*F)_OPTIONS) -i$(BUILDDIR) $(INCDIRS)
@# move stub files
! @-if test -f $(<D)/$(*F)_stub.h; then $(MV) $(<D)/$(*F)_stub.[ch] $(HOUTDIR)/$(*D); fi
@# create dependency file
! @$(HC) $< $(HC-OPTIONS) -M -optdep-f -optdep$(*F).d -i$(BUILDDIR)
@sed -e 's|$(subst .hs,,$<)\.o|$(HOUTDIR)/$*\.o|' $(*F).d > $(HOUTDIR)/$*.d
@rm $(*F).d
--- 168,174 ----
$(HC) -o $@ -package-name port -ohi $(BUILDDIR)/Graphics/UI/$(*D)/$(*F).hi -odir $(HOUTDIR)/$(*D) -c $< $(HC-OPTIONS) $($(*F)_OPTIONS) -i$(BUILDDIR) $(INCDIRS)
@# move stub files
! @-if test -f $(<D)/$(*F)_stub.h; then $(MV) $(<D)/$(*F)_stub.[ch] $(HOUTDIR)/$(*D); fi
@# create dependency file
! @$(HC) $< $(HC-OPTIONS) -M -optdep-f -optdep$(*F).d -i$(BUILDDIR)
@sed -e 's|$(subst .hs,,$<)\.o|$(HOUTDIR)/$*\.o|' $(*F).d > $(HOUTDIR)/$*.d
@rm $(*F).d
***************
*** 192,200 ****
$(COBJS): $(COUTDIR)/%.c.o: %.c
$(CC) -o $@ -c $< $(CC-OPTIONS) -MD $(INCDIRS)
! @#move dependendcy files only needed for gcc 2.xx
! @#@mv $(*F).d $(COUTDIR)/$(*F).c.d
!
! $(GSTSTUBOBJS) : $(COUTDIR)/%.o: %.c
! $(CC) -o $@ -c $< $(CC-OPTIONS) -MD $(INCDIRS)
#--------------------------------------------------------------------------
--- 179,184 ----
$(COBJS): $(COUTDIR)/%.c.o: %.c
$(CC) -o $@ -c $< $(CC-OPTIONS) -MD $(INCDIRS)
! @#move dependendcy files only needed for gcc 2.xx
! @#@mv $(*F).d $(COUTDIR)/$(*F).c.d
#--------------------------------------------------------------------------
***************
*** 236,240 ****
# extra commands: clean up all directories and show linecounts.
clean:
! $(RM) $(HSLIB)
$(RM) $(DOCDIR)/*.html $(DOCDIR)/*.gif $(DOCDIR)/*.css $(DOCDIR)/*.haddock
$(RM) $(HOUTDIR)/*.*
--- 220,224 ----
# extra commands: clean up all directories and show linecounts.
clean:
! $(RM) $(MAINLIB)
$(RM) $(DOCDIR)/*.html $(DOCDIR)/*.gif $(DOCDIR)/*.css $(DOCDIR)/*.haddock
$(RM) $(HOUTDIR)/*.*
|
|
From: <kr_...@us...> - 2003-09-07 22:57:32
|
Update of /cvsroot/htoolkit/HSQL/MySQL
In directory sc8-pr-cvs1:/tmp/cvs-serv8597/MySQL
Modified Files:
HSQL.hsc
Log Message:
comments
Index: HSQL.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/MySQL/HSQL.hsc,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** HSQL.hsc 7 Sep 2003 19:16:11 -0000 1.1
--- HSQL.hsc 7 Sep 2003 22:57:25 -0000 1.2
***************
*** 133,137 ****
-----------------------------------------------------------------------------------------
! connect :: String -> String -> String -> String -> IO Connection
connect server database user authentication = do
pMYSQL <- mysql_init nullPtr
--- 133,142 ----
-----------------------------------------------------------------------------------------
! -- | Makes a new connection to the database server.
! connect :: String -- ^ Server name
! -> String -- ^ Database name
! -> String -- ^ User identifier
! -> String -- ^ Authentication string (password)
! -> IO Connection
connect server database user authentication = do
pMYSQL <- mysql_init nullPtr
***************
*** 147,151 ****
when (res == nullPtr) (handleSqlError pMYSQL)
return (Connection pMYSQL)
!
disconnect :: Connection -> IO ()
disconnect (Connection pMYSQL) = mysql_close pMYSQL
--- 152,157 ----
when (res == nullPtr) (handleSqlError pMYSQL)
return (Connection pMYSQL)
!
! -- | Closes the connection.
disconnect :: Connection -> IO ()
disconnect (Connection pMYSQL) = mysql_close pMYSQL
***************
*** 155,163 ****
-----------------------------------------------------------------------------------------
execute :: Connection -> String -> IO ()
execute conn@(Connection pMYSQL) query = do
res <- withCString query (mysql_query pMYSQL)
when (res /= 0) (handleSqlError pMYSQL)
!
query :: Connection -> String -> IO Statement
query conn@(Connection pMYSQL) query = do
--- 161,171 ----
-----------------------------------------------------------------------------------------
+ -- | Execute statement
execute :: Connection -> String -> IO ()
execute conn@(Connection pMYSQL) query = do
res <- withCString query (mysql_query pMYSQL)
when (res /= 0) (handleSqlError pMYSQL)
!
! -- | Executes the statement and returns a 'Statement' value which represents the result set
query :: Connection -> String -> IO Statement
query conn@(Connection pMYSQL) query = do
***************
*** 210,213 ****
--- 218,223 ----
mkSqlType (#const FIELD_TYPE_NULL) _ _ = SqlUnknown
+ -- | 'fetch' fetches the next rowset of data from the result set.
+ -- The values from columns can be retrieved with 'getFieldValue' function.
fetch :: Statement -> IO Bool
fetch (Statement {pRes=pRes,currRow=currRow})
***************
*** 218,221 ****
--- 228,234 ----
return (pRow /= nullPtr)
+ -- | 'closeStatement' stops processing associated with a specific statement, closes any open cursors
+ -- associated with the statement, discards pending results, and frees all resources associated with
+ -- the statement.
closeStatement :: Statement -> IO ()
closeStatement (Statement {pRes=pRes})
***************
*** 227,230 ****
--- 240,247 ----
-----------------------------------------------------------------------------------------
+ -- | The 'inTransaction' function executes the specified action in transaction mode.
+ -- If the action completes successfully then the transaction will be commited.
+ -- If the action completes with an exception then the transaction will be rolled back
+ -- and the exception will be throw again.
inTransaction :: Connection -> (Connection -> IO a) -> IO a
inTransaction conn action = do
***************
*** 364,368 ****
! getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
getFieldValueMB (Statement {currRow=currRow, fields=fieldDefs}) name = do
row <- readIORef currRow
--- 381,389 ----
! -- | Retrieves the value of field with the specified name.
! -- The returned value is Nothing if the field value is @null@.
! getFieldValueMB :: SqlBind a => Statement
! -> String -- ^ Field name
! -> IO (Maybe a) -- ^ Field value or Nothing
getFieldValueMB (Statement {currRow=currRow, fields=fieldDefs}) name = do
row <- readIORef currRow
***************
*** 377,381 ****
Nothing -> throwDyn (SqlBadTypeCast name sqlType)
! getFieldValue :: SqlBind a => Statement -> String -> IO a
getFieldValue stmt name = do
mb_v <- getFieldValueMB stmt name
--- 398,406 ----
Nothing -> throwDyn (SqlBadTypeCast name sqlType)
! -- | Retrieves the value of field with the specified name.
! -- If the field value is @null@ then the function will throw 'SqlFetchNull' exception.
! getFieldValue :: SqlBind a => Statement
! -> String -- ^ Field name
! -> IO a -- ^ Field value
getFieldValue stmt name = do
mb_v <- getFieldValueMB stmt name
***************
*** 384,392 ****
Just a -> return a
! getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a
getFieldValue' stmt name def = do
mb_v <- getFieldValueMB stmt name
return (case mb_v of { Nothing -> def; Just a -> a })
getFieldValueType :: Statement -> String -> (SqlType, Bool)
getFieldValueType stmt name = (sqlType, nullable)
--- 409,423 ----
Just a -> return a
! -- | Retrieves the value of field with the specified name.
! -- If the field value is @null@ then the function will return the default value.
! getFieldValue' :: SqlBind a => Statement
! -> String -- ^ Field name
! -> a -- ^ Default field value
! -> IO a -- ^ Field value
getFieldValue' stmt name def = do
mb_v <- getFieldValueMB stmt name
return (case mb_v of { Nothing -> def; Just a -> a })
+ -- | Returns the type and the @nullable@ flag for field with specified name
getFieldValueType :: Statement -> String -> (SqlType, Bool)
getFieldValueType stmt name = (sqlType, nullable)
***************
*** 394,397 ****
--- 425,429 ----
(sqlType,nullable,colNumber) = findFieldInfo name (fields stmt) 1
+ -- | Returns the list of fields with their types and @nullable@ flags
getFieldsTypes :: Statement -> [(String, SqlType, Bool)]
getFieldsTypes = fields
***************
*** 407,415 ****
-----------------------------------------------------------------------------------------
! forEachRow :: (Statement -> s -> IO s) -> Statement -> s -> IO s
forEachRow f stmt s = do
success <- fetch stmt
if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s
forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()
forEachRow' f stmt = do
--- 439,454 ----
-----------------------------------------------------------------------------------------
! -- | The 'forEachRow' function iterates through the result set in 'Statement' and
! -- executes the given action for each row in the set. After processing the last row
! -- the statement is automatically closed.
! forEachRow :: (Statement -> s -> IO s) -- ^ an action
! -> Statement -- ^ the statement
! -> s -- ^ initial state
! -> IO s -- ^ final state
forEachRow f stmt s = do
success <- fetch stmt
if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s
+ -- | The 'forEachRow\'' function is analogous to 'forEachRow' but doesn't provide state.
forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()
forEachRow' f stmt = do
***************
*** 417,420 ****
--- 456,462 ----
if success then f stmt >> forEachRow' f stmt else closeStatement stmt
+ -- | The 'collectRows' function iterates through the result set in 'Statement' and
+ -- executes the given action for each row in the set. The values returned from action
+ -- are collected and returned as list.
collectRows :: (Statement -> IO a) -> Statement -> IO [a]
collectRows f stmt = loop
|
|
From: <kr_...@us...> - 2003-09-07 22:57:31
|
Update of /cvsroot/htoolkit/HSQL/PostgreSQL
In directory sc8-pr-cvs1:/tmp/cvs-serv8597/PostgreSQL
Modified Files:
HSQL.hsc
Log Message:
comments
Index: HSQL.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/PostgreSQL/HSQL.hsc,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** HSQL.hsc 7 Sep 2003 19:28:01 -0000 1.4
--- HSQL.hsc 7 Sep 2003 22:57:25 -0000 1.5
***************
*** 161,165 ****
-----------------------------------------------------------------------------------------
! connect :: String -> String -> String -> String -> IO Connection
connect server database user authentication = do
pServer <- newCString server
--- 161,170 ----
-----------------------------------------------------------------------------------------
! -- | Makes a new connection to the database server.
! connect :: String -- ^ Server name
! -> String -- ^ Database name
! -> String -- ^ User identifier
! -> String -- ^ Authentication string (password)
! -> IO Connection
connect server database user authentication = do
pServer <- newCString server
***************
*** 178,181 ****
--- 183,187 ----
return (Connection pConn)
+ -- | Closes the connection.
disconnect :: Connection -> IO ()
disconnect (Connection pConn) = pqFinish pConn
***************
*** 186,189 ****
--- 192,196 ----
-----------------------------------------------------------------------------------------
+ -- | Execute statement
execute :: Connection -> String -> IO ()
execute conn@(Connection pConn) sqlExpr = do
***************
*** 198,201 ****
--- 205,209 ----
return ()
+ -- | Executes the statement and returns a 'Statement' value which represents the result set
query :: Connection -> String -> IO Statement
query conn@(Connection pConn) query = do
***************
*** 258,261 ****
--- 266,271 ----
mkSqlType (#const UNKNOWNOID) size = SqlUnknown
+ -- | 'fetch' fetches the next rowset of data from the result set.
+ -- The values from columns can be retrieved with 'getFieldValue' function.
fetch :: Statement -> IO Bool
fetch (Statement {countTuples=countTuples, tupleIndex=tupleIndex}) = do
***************
*** 266,269 ****
--- 276,282 ----
else writeIORef tupleIndex index' >> return True
+ -- | 'closeStatement' stops processing associated with a specific statement, closes any open cursors
+ -- associated with the statement, discards pending results, and frees all resources associated with
+ -- the statement.
closeStatement :: Statement -> IO ()
closeStatement _ = return ()
***************
*** 273,277 ****
-----------------------------------------------------------------------------------------
! inTransaction :: Connection -> (Connection -> IO a) -> IO a
inTransaction conn action = do
execute conn "begin"
--- 286,296 ----
-----------------------------------------------------------------------------------------
! -- | The 'inTransaction' function executes the specified action in transaction mode.
! -- If the action completes successfully then the transaction will be commited.
! -- If the action completes with an exception then the transaction will be rolled back
! -- and the exception will be throw again.
! inTransaction :: Connection
! -> (Connection -> IO a) -- ^ an action
! -> IO a -- ^ the returned value is the result returned from action
inTransaction conn action = do
execute conn "begin"
***************
*** 544,548 ****
showHex = showIntAtBase 16 intToDigit
! getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
getFieldValueMB (Statement {pRes=pRes, connection=conn, fields=fieldDefs, countTuples=countTuples, tupleIndex=tupleIndex}) name = do
index <- readIORef tupleIndex
--- 563,571 ----
showHex = showIntAtBase 16 intToDigit
! -- | Retrieves the value of field with the specified name.
! -- The returned value is Nothing if the field value is @null@.
! getFieldValueMB :: SqlBind a => Statement
! -> String -- ^ Field name
! -> IO (Maybe a) -- ^ Field value or Nothing
getFieldValueMB (Statement {pRes=pRes, connection=conn, fields=fieldDefs, countTuples=countTuples, tupleIndex=tupleIndex}) name = do
index <- readIORef tupleIndex
***************
*** 558,562 ****
Nothing -> throwDyn (SqlBadTypeCast name sqlType)
! getFieldValue :: SqlBind a => Statement -> String -> IO a
getFieldValue stmt name = do
mb_v <- getFieldValueMB stmt name
--- 581,589 ----
Nothing -> throwDyn (SqlBadTypeCast name sqlType)
! -- | Retrieves the value of field with the specified name.
! -- If the field value is @null@ then the function will throw 'SqlFetchNull' exception.
! getFieldValue :: SqlBind a => Statement
! -> String -- ^ Field name
! -> IO a -- ^ Field value
getFieldValue stmt name = do
mb_v <- getFieldValueMB stmt name
***************
*** 565,573 ****
Just a -> return a
! getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a
getFieldValue' stmt name def = do
mb_v <- getFieldValueMB stmt name
return (case mb_v of { Nothing -> def; Just a -> a })
getFieldValueType :: Statement -> String -> SqlType
getFieldValueType stmt name = sqlType
--- 592,606 ----
Just a -> return a
! -- | Retrieves the value of field with the specified name.
! -- If the field value is @null@ then the function will return the default value.
! getFieldValue' :: SqlBind a => Statement
! -> String -- ^ Field name
! -> a -- ^ Default field value
! -> IO a -- ^ Field value
getFieldValue' stmt name def = do
mb_v <- getFieldValueMB stmt name
return (case mb_v of { Nothing -> def; Just a -> a })
+ -- | Returns the type and the @nullable@ flag for field with specified name
getFieldValueType :: Statement -> String -> SqlType
getFieldValueType stmt name = sqlType
***************
*** 575,578 ****
--- 608,612 ----
(sqlType,colNumber) = findFieldInfo name (fields stmt) 1
+ -- | Returns the list of fields with their types and @nullable@ flags
getFieldsTypes :: Statement -> [(String, SqlType)]
getFieldsTypes = fields
***************
*** 589,597 ****
-----------------------------------------------------------------------------------------
! forEachRow :: (Statement -> s -> IO s) -> Statement -> s -> IO s
forEachRow f stmt s = do
success <- fetch stmt
if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s
forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()
forEachRow' f stmt = do
--- 623,638 ----
-----------------------------------------------------------------------------------------
! -- | The 'forEachRow' function iterates through the result set in 'Statement' and
! -- executes the given action for each row in the set. After processing the last row
! -- the statement is automatically closed.
! forEachRow :: (Statement -> s -> IO s) -- ^ an action
! -> Statement -- ^ the statement
! -> s -- ^ initial state
! -> IO s -- ^ final state
forEachRow f stmt s = do
success <- fetch stmt
if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s
+ -- | The 'forEachRow\'' function is analogous to 'forEachRow' but doesn't provide state.
forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()
forEachRow' f stmt = do
***************
*** 599,602 ****
--- 640,646 ----
if success then f stmt >> forEachRow' f stmt else closeStatement stmt
+ -- | The 'collectRows' function iterates through the result set in 'Statement' and
+ -- executes the given action for each row in the set. The values returned from action
+ -- are collected and returned as list.
collectRows :: (Statement -> IO a) -> Statement -> IO [a]
collectRows f stmt = loop
|
|
From: <kr_...@us...> - 2003-09-07 22:57:31
|
Update of /cvsroot/htoolkit/HSQL/ODBC
In directory sc8-pr-cvs1:/tmp/cvs-serv8597/ODBC
Modified Files:
HSQL.hsc
Log Message:
comments
Index: HSQL.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/ODBC/HSQL.hsc,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** HSQL.hsc 6 Sep 2003 22:44:13 -0000 1.2
--- HSQL.hsc 7 Sep 2003 22:57:25 -0000 1.3
***************
*** 198,202 ****
-----------------------------------------------------------------------------------------
! connect :: String -> String -> String -> IO Connection
connect server user authentication = withForeignPtr myEnvironment $ \hEnv -> do
(phDBC :: Ptr HDBC) <- malloc
--- 198,206 ----
-----------------------------------------------------------------------------------------
! -- | Makes a new connection to the database server.
! connect :: String -- ^ Data source name
! -> String -- ^ User identifier
! -> String -- ^ Authentication string (password)
! -> IO Connection -- ^ the returned value represents the new connection
connect server user authentication = withForeignPtr myEnvironment $ \hEnv -> do
(phDBC :: Ptr HDBC) <- malloc
***************
*** 214,218 ****
handleSqlResult (#const SQL_HANDLE_ENV) hEnv res
return (Connection {hDBC=hDBC, environment=myEnvironment})
!
disconnect :: Connection -> IO ()
disconnect (Connection {hDBC=hDBC}) = do
--- 218,223 ----
handleSqlResult (#const SQL_HANDLE_ENV) hEnv res
return (Connection {hDBC=hDBC, environment=myEnvironment})
!
! -- | Closes the connection.
disconnect :: Connection -> IO ()
disconnect (Connection {hDBC=hDBC}) = do
***************
*** 225,228 ****
--- 230,234 ----
-----------------------------------------------------------------------------------------
+ -- | Execute statement
execute :: Connection -> String -> IO ()
execute conn@(Connection {hDBC=hDBC}) query = do
***************
*** 242,245 ****
--- 248,252 ----
free pFIELD
+ -- | Executes the statement and returns a 'Statement' value which represents the result set
query :: Connection -> String -> IO Statement
query conn@(Connection {hDBC=hDBC}) query = do
***************
*** 302,305 ****
--- 309,314 ----
{-# NOINLINE fetch #-}
+ -- | 'fetch' fetches the next rowset of data from the result set.
+ -- The values from columns can be retrieved with 'getFieldValue' function.
fetch :: Statement -> IO Bool
fetch stmt = do
***************
*** 308,312 ****
return (res /= (#const SQL_NO_DATA))
!
closeStatement :: Statement -> IO ()
closeStatement stmt = do
--- 317,323 ----
return (res /= (#const SQL_NO_DATA))
! -- | 'closeStatement' stops processing associated with a specific statement, closes any open cursors
! -- associated with the statement, discards pending results, and frees all resources associated with
! -- the statement.
closeStatement :: Statement -> IO ()
closeStatement stmt = do
***************
*** 318,322 ****
-----------------------------------------------------------------------------------------
! inTransaction :: Connection -> (Connection -> IO a) -> IO a
inTransaction conn@(Connection {hDBC=hDBC, environment=envRef}) action = withForeignPtr envRef $ \hEnv -> do
sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_OFF)
--- 329,339 ----
-----------------------------------------------------------------------------------------
! -- | The 'inTransaction' function executes the specified action in transaction mode.
! -- If the action completes successfully then the transaction will be commited.
! -- If the action completes with an exception then the transaction will be rolled back
! -- and the exception will be throw again.
! inTransaction :: Connection
! -> (Connection -> IO a) -- ^ an action
! -> IO a -- ^ the returned value is the result returned from action
inTransaction conn@(Connection {hDBC=hDBC, environment=envRef}) action = withForeignPtr envRef $ \hEnv -> do
sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_OFF)
***************
*** 418,422 ****
foreign import ccall unsafe mktime :: Ptr () -> IO CTime
! getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
getFieldValueMB (Statement {hSTMT=hSTMT, fields=fields, fetchBuffer=buffer, fetchBufferSize=bufferSize}) name = do
let dataBuffer = buffer `plusPtr` (#const sizeof(SQLINTEGER))
--- 435,443 ----
foreign import ccall unsafe mktime :: Ptr () -> IO CTime
! -- | Retrieves the value of field with the specified name.
! -- The returned value is Nothing if the field value is @null@.
! getFieldValueMB :: SqlBind a => Statement
! -> String -- ^ Field name
! -> IO (Maybe a) -- ^ Field value or Nothing
getFieldValueMB (Statement {hSTMT=hSTMT, fields=fields, fetchBuffer=buffer, fetchBufferSize=bufferSize}) name = do
let dataBuffer = buffer `plusPtr` (#const sizeof(SQLINTEGER))
***************
*** 467,471 ****
SqlLongVarBinary _ -> (#const SQL_C_BINARY)
! getFieldValue :: SqlBind a => Statement -> String -> IO a
getFieldValue stmt name = do
mb_v <- getFieldValueMB stmt name
--- 488,496 ----
SqlLongVarBinary _ -> (#const SQL_C_BINARY)
! -- | Retrieves the value of field with the specified name.
! -- If the field value is @null@ then the function will throw 'SqlFetchNull' exception.
! getFieldValue :: SqlBind a => Statement
! -> String -- ^ Field name
! -> IO a -- ^ Field value
getFieldValue stmt name = do
mb_v <- getFieldValueMB stmt name
***************
*** 474,487 ****
Just a -> return a
! getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a
getFieldValue' stmt name def = do
mb_v <- getFieldValueMB stmt name
return (case mb_v of { Nothing -> def; Just a -> a })
!
! getFieldValueType :: Statement -> String -> (SqlType, Bool)
getFieldValueType stmt name = (sqlType, nullable)
where
(sqlType,nullable,colNumber) = findFieldInfo name (fields stmt) 1
getFieldsTypes :: Statement -> [(String, SqlType, Bool)]
getFieldsTypes = fields
--- 499,521 ----
Just a -> return a
! -- | Retrieves the value of field with the specified name.
! -- If the field value is @null@ then the function will return the default value.
! getFieldValue' :: SqlBind a => Statement
! -> String -- ^ Field name
! -> a -- ^ Default field value
! -> IO a -- ^ Field value
getFieldValue' stmt name def = do
mb_v <- getFieldValueMB stmt name
return (case mb_v of { Nothing -> def; Just a -> a })
!
! -- | Returns the type and the @nullable@ flag for field with specified name
! getFieldValueType :: Statement
! -> String -- ^ Field name
! -> (SqlType, Bool) -- ^ Field type and @nullable@
getFieldValueType stmt name = (sqlType, nullable)
where
(sqlType,nullable,colNumber) = findFieldInfo name (fields stmt) 1
+ -- | Returns the list of fields with their types and @nullable@ flags
getFieldsTypes :: Statement -> [(String, SqlType, Bool)]
getFieldsTypes = fields
***************
*** 497,510 ****
-----------------------------------------------------------------------------------------
! forEachRow :: (Statement -> s -> IO s) -> Statement -> s -> IO s
forEachRow f stmt s = do
success <- fetch stmt
if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s
!
forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()
forEachRow' f stmt = do
success <- fetch stmt
if success then f stmt >> forEachRow' f stmt else closeStatement stmt
!
collectRows :: (Statement -> IO a) -> Statement -> IO [a]
collectRows f stmt = loop
--- 531,554 ----
-----------------------------------------------------------------------------------------
! -- | The 'forEachRow' function iterates through the result set in 'Statement' and
! -- executes the given action for each row in the set. After processing the last row
! -- the statement is automatically closed.
! forEachRow :: (Statement -> s -> IO s) -- ^ an action
! -> Statement -- ^ the statement
! -> s -- ^ initial state
! -> IO s -- ^ final state
forEachRow f stmt s = do
success <- fetch stmt
if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s
!
! -- | The 'forEachRow\'' function is analogous to 'forEachRow' but doesn't provide state.
forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()
forEachRow' f stmt = do
success <- fetch stmt
if success then f stmt >> forEachRow' f stmt else closeStatement stmt
!
! -- | The 'collectRows' function iterates through the result set in 'Statement' and
! -- executes the given action for each row in the set. The values returned from action
! -- are collected and returned as list.
collectRows :: (Statement -> IO a) -> Statement -> IO [a]
collectRows f stmt = loop
|
|
From: <kr_...@us...> - 2003-09-07 22:56:24
|
Update of /cvsroot/htoolkit/HSQL In directory sc8-pr-cvs1:/tmp/cvs-serv8537 Modified Files: Makefile Log Message: bugfix Index: Makefile =================================================================== RCS file: /cvsroot/htoolkit/HSQL/Makefile,v retrieving revision 1.4 retrieving revision 1.5 diff -C2 -d -r1.4 -r1.5 *** Makefile 6 Sep 2003 21:52:42 -0000 1.4 --- Makefile 7 Sep 2003 22:56:18 -0000 1.5 *************** *** 16,22 **** HI_SRC = $(patsubst %.hs,%.hi,$(HS_SRC)) ! ifneq "$(HADDOCK)" "" ! HS_PPS = $(addsuffix .raw-hs, $(basename $(HS_SRC))) HADDOCK = echo endif --- 16,23 ---- HI_SRC = $(patsubst %.hs,%.hi,$(HS_SRC)) ! ifeq "$(HADDOCK)" "" HADDOCK = echo + else + HS_PPS = $(addsuffix .raw-hs, $(basename $(HS_SRC))) endif *************** *** 47,55 **** rm -f $(HS_PPS) ! doc : $(HS_PPS) mkdir -p doc $(HADDOCK) -h -o doc $(HS_PPS) ! install: libHSsql.a $(HI_SRC) doc $(INSTALL) libHSsql.a $(prefix)/libHSsql.a $(INSTALL) -d $(prefix)/imports/Database --- 48,56 ---- rm -f $(HS_PPS) ! docs : $(HS_PPS) mkdir -p doc $(HADDOCK) -h -o doc $(HS_PPS) ! install: libHSsql.a $(HI_SRC) docs $(INSTALL) libHSsql.a $(prefix)/libHSsql.a $(INSTALL) -d $(prefix)/imports/Database |
|
From: <kr_...@us...> - 2003-09-07 19:28:05
|
Update of /cvsroot/htoolkit/HSQL/PostgreSQL In directory sc8-pr-cvs1:/tmp/cvs-serv3737/PostgreSQL Modified Files: HSQL.hsc Log Message: bugfix Index: HSQL.hsc =================================================================== RCS file: /cvsroot/htoolkit/HSQL/PostgreSQL/HSQL.hsc,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** HSQL.hsc 6 Sep 2003 22:48:00 -0000 1.3 --- HSQL.hsc 7 Sep 2003 19:28:01 -0000 1.4 *************** *** 307,310 **** --- 307,311 ---- toSqlValue s = '\'' : foldr mapChar "'" s where + mapChar '\\' s = '\\':'\\':s mapChar '\'' s = '\\':'\'':s mapChar '\n' s = '\\':'n':s |
|
From: <kr_...@us...> - 2003-09-07 19:16:15
|
Update of /cvsroot/htoolkit/HSQL/MySQL
In directory sc8-pr-cvs1:/tmp/cvs-serv1819/MySQL
Added Files:
HSQL.hsc
Log Message:
Add support for MySQL
--- NEW FILE: HSQL.hsc ---
#include <config.h>
module Database.MySQL.HSQL
( SqlBind(..), SqlError(..), SqlType(..), Connection, Statement
, catchSql -- :: IO a -> (SqlError -> IO a) -> IO a
, handleSql -- :: (SqlError -> IO a) -> IO a -> IO a
, sqlExceptions -- :: Exception -> Maybe SqlError
, connect -- :: String -> String -> String -> IO Connection
, disconnect -- :: Connection -> IO ()
, execute -- :: Connection -> String -> IO ()
, query -- :: Connection -> String -> IO Statement
, closeStatement -- :: Statement -> IO ()
, fetch -- :: Statement -> IO Bool
, inTransaction -- :: Connection -> (Connection -> IO a) -> IO a
, getFieldValueMB -- :: SqlBind a => Statement -> String -> IO (Maybe a)
, getFieldValue -- :: SqlBind a => Statement -> String -> IO a
, getFieldValue' -- :: SqlBind a => Statement -> String -> a -> IO a
, getFieldValueType -- :: Statement -> String -> (SqlType, Bool)
, getFieldsTypes -- :: Statement -> [(String, SqlType, Bool)]
, forEachRow -- :: (Statement -> s -> IO s) -> Statement -> s -> IO s
, forEachRow' -- :: (Statement -> IO ()) -> Statement -> IO ()
, collectRows -- :: (Statement -> IO s) -> Statement -> IO [s]
) where
import Data.Dynamic
import Data.Bits
import Data.IORef
import Data.Char
import Foreign
import Foreign.C
import Control.Monad(when,unless)
import Control.Exception (throwDyn, catchDyn, dynExceptions, Exception(..))
import System.Time
import System.IO.Unsafe
import Text.ParserCombinators.ReadP
import Text.Read
#ifdef ENABLED_GUI
import Graphics.UI.HGUI.BasicTypes
import Graphics.UI.HGUI.BasicClasses
#endif
#include <mysql.h>
#include <time.h>
type MYSQL = Ptr ()
type MYSQL_RES = Ptr ()
type MYSQL_FIELD = Ptr ()
type MYSQL_ROW = Ptr CString
foreign import ccall "mysql.h mysql_init" mysql_init :: MYSQL -> IO MYSQL
foreign import ccall "mysql.h mysql_real_connect" mysql_real_connect :: MYSQL -> CString -> CString -> CString -> CString -> Int -> CString -> Int -> IO MYSQL
foreign import ccall "mysql.h mysql_close" mysql_close :: MYSQL -> IO ()
foreign import ccall "mysql.h mysql_errno" mysql_errno :: MYSQL -> IO Int
foreign import ccall "mysql.h mysql_error" mysql_error :: MYSQL -> IO CString
foreign import ccall "mysql.h mysql_query" mysql_query :: MYSQL -> CString -> IO Int
foreign import ccall "mysql.h mysql_use_result" mysql_use_result :: MYSQL -> IO MYSQL_RES
foreign import ccall "mysql.h mysql_fetch_field" mysql_fetch_field :: MYSQL_RES -> IO MYSQL_FIELD
foreign import ccall "mysql.h mysql_free_result" mysql_free_result :: MYSQL_RES -> IO ()
foreign import ccall "mysql.h mysql_fetch_row" mysql_fetch_row :: MYSQL_RES -> IO MYSQL_ROW
newtype Connection = Connection MYSQL
data Statement
= Statement
{ pRes :: !MYSQL_RES
, connection :: !Connection
, fields :: ![FieldDef]
, currRow :: IORef MYSQL_ROW
}
type FieldDef = (String, SqlType, Bool)
data SqlType
= SqlChar Int
| SqlVarChar Int
| SqlNumeric Int Int
| SqlSmallInt
| SqlMedInt
| SqlInteger
| SqlReal
| SqlDouble
| SqlTinyInt
| SqlBigInt
| SqlDate
| SqlTime
| SqlTimeStamp
| SqlDateTime
| SqlYear
| SqlSET
| SqlENUM
| SqlBLOB
| SqlUnknown
deriving (Eq, Show)
data SqlError
= SqlError
{ seNativeError :: Int
, seErrorMsg :: String
}
| SqlBadTypeCast
{ seFieldName :: String
, seFieldType :: SqlType
}
| SqlFetchNull
{ seFieldName :: String
}
deriving (Typeable, Show)
-----------------------------------------------------------------------------------------
-- routines for handling exceptions
-----------------------------------------------------------------------------------------
catchSql :: IO a -> (SqlError -> IO a) -> IO a
catchSql = catchDyn
handleSql :: (SqlError -> IO a) -> IO a -> IO a
handleSql h f = catchDyn f h
sqlExceptions :: Exception -> Maybe SqlError
sqlExceptions e = dynExceptions e >>= fromDynamic
handleSqlError :: MYSQL -> IO a
handleSqlError pMYSQL = do
errno <- mysql_errno pMYSQL
errMsg <- mysql_error pMYSQL >>= peekCString
throwDyn (SqlError errno errMsg)
-----------------------------------------------------------------------------------------
-- Connect/Disconnect
-----------------------------------------------------------------------------------------
connect :: String -> String -> String -> String -> IO Connection
connect server database user authentication = do
pMYSQL <- mysql_init nullPtr
pServer <- newCString server
pDatabase <- newCString database
pUser <- newCString user
pAuthentication <- newCString authentication
res <- mysql_real_connect pMYSQL pServer pUser pAuthentication pDatabase 0 nullPtr 0
free pServer
free pDatabase
free pUser
free pAuthentication
when (res == nullPtr) (handleSqlError pMYSQL)
return (Connection pMYSQL)
disconnect :: Connection -> IO ()
disconnect (Connection pMYSQL) = mysql_close pMYSQL
-----------------------------------------------------------------------------------------
-- queries
-----------------------------------------------------------------------------------------
execute :: Connection -> String -> IO ()
execute conn@(Connection pMYSQL) query = do
res <- withCString query (mysql_query pMYSQL)
when (res /= 0) (handleSqlError pMYSQL)
query :: Connection -> String -> IO Statement
query conn@(Connection pMYSQL) query = do
res <- withCString query (mysql_query pMYSQL)
when (res /= 0) (handleSqlError pMYSQL)
currRow <- newIORef nullPtr
pRes <- mysql_use_result pMYSQL
if (pRes == nullPtr)
then do
errno <- mysql_errno pMYSQL
when (errno /= 0) (handleSqlError pMYSQL)
return (Statement {pRes=nullPtr, fields=[], connection=conn, currRow=currRow})
else do
fieldDefs <- getFieldDefs pRes
return (Statement {pRes=pRes, fields=fieldDefs, connection=conn, currRow=currRow})
where
getFieldDefs pRes = do
pField <- mysql_fetch_field pRes
if pField == nullPtr
then return []
else do
name <- (#peek MYSQL_FIELD, name) pField >>= peekCString
(dataType :: Int) <- (#peek MYSQL_FIELD, type) pField
(columnSize :: Int) <- (#peek MYSQL_FIELD, length) pField
(flags :: Int) <- (#peek MYSQL_FIELD, flags) pField
(decimalDigits :: Int) <- (#peek MYSQL_FIELD, decimals) pField
let sqlType = mkSqlType dataType columnSize decimalDigits
defs <- getFieldDefs pRes
return ((name,sqlType,(flags .&. (#const NOT_NULL_FLAG)) == 0):defs)
mkSqlType :: Int -> Int -> Int -> SqlType
mkSqlType (#const FIELD_TYPE_STRING ) size _ = SqlChar size
mkSqlType (#const FIELD_TYPE_VAR_STRING) size _ = SqlVarChar size
mkSqlType (#const FIELD_TYPE_DECIMAL) size prec = SqlNumeric size prec
mkSqlType (#const FIELD_TYPE_SHORT) _ _ = SqlSmallInt
mkSqlType (#const FIELD_TYPE_INT24) _ _ = SqlMedInt
mkSqlType (#const FIELD_TYPE_LONG) _ _ = SqlInteger
mkSqlType (#const FIELD_TYPE_FLOAT) _ _ = SqlReal
mkSqlType (#const FIELD_TYPE_DOUBLE ) _ _ = SqlDouble
mkSqlType (#const FIELD_TYPE_TINY) _ _ = SqlTinyInt
mkSqlType (#const FIELD_TYPE_LONGLONG) _ _ = SqlBigInt
mkSqlType (#const FIELD_TYPE_DATE ) _ _ = SqlDate
mkSqlType (#const FIELD_TYPE_TIME ) _ _ = SqlTime
mkSqlType (#const FIELD_TYPE_TIMESTAMP ) _ _ = SqlTimeStamp
mkSqlType (#const FIELD_TYPE_DATETIME) _ _ = SqlDateTime
mkSqlType (#const FIELD_TYPE_YEAR) _ _ = SqlYear
mkSqlType (#const FIELD_TYPE_BLOB) _ _ = SqlBLOB
mkSqlType (#const FIELD_TYPE_SET) _ _ = SqlSET
mkSqlType (#const FIELD_TYPE_ENUM) _ _ = SqlENUM
mkSqlType (#const FIELD_TYPE_NULL) _ _ = SqlUnknown
fetch :: Statement -> IO Bool
fetch (Statement {pRes=pRes,currRow=currRow})
| pRes == nullPtr = return False
| otherwise = do
pRow <- mysql_fetch_row pRes
writeIORef currRow pRow
return (pRow /= nullPtr)
closeStatement :: Statement -> IO ()
closeStatement (Statement {pRes=pRes})
| pRes == nullPtr = return ()
| otherwise = mysql_free_result pRes
-----------------------------------------------------------------------------------------
-- transactions
-----------------------------------------------------------------------------------------
inTransaction :: Connection -> (Connection -> IO a) -> IO a
inTransaction conn action = do
execute conn "begin"
r <- catchSql (action conn) (\err -> execute conn "rollback" >>= throwDyn err)
execute conn "commit"
return r
-----------------------------------------------------------------------------------------
-- binding
-----------------------------------------------------------------------------------------
class SqlBind a where
fromSqlValue :: SqlType -> String -> Maybe a
toSqlValue :: a -> String
instance SqlBind Int where
fromSqlValue SqlInteger s = Just (read s)
fromSqlValue SqlSmallInt s = Just (read s)
fromSqlValue _ s = Nothing
toSqlValue val = show val
instance SqlBind Integer where
fromSqlValue SqlInteger s = Just (read s)
fromSqlValue SqlSmallInt s = Just (read s)
fromSqlValue SqlBigInt s = Just (read s)
fromSqlValue _ s = Nothing
toSqlValue val = show val
instance SqlBind String where
fromSqlValue _ = Just
toSqlValue s = '\'' : foldr mapChar "'" s
where
mapChar '\\' s = '\\':'\\':s
mapChar '\'' s = '\\':'\'':s
mapChar '\n' s = '\\':'n':s
mapChar '\r' s = '\\':'r':s
mapChar '\t' s = '\\':'t':s
mapChar c s = c:s
instance SqlBind Double where
fromSqlValue (SqlNumeric _ _) s = Just (read s)
fromSqlValue SqlDouble s = Just (read s)
fromSqlValue SqlReal s = Just (read s)
fromSqlValue _ s = Nothing
toSqlValue val = show val
mkClockTime :: Int -> Int -> Int -> Int -> Int -> Int -> ClockTime
mkClockTime year mon mday hour min sec =
unsafePerformIO $ do
allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
(#poke struct tm,tm_sec ) p_tm (fromIntegral sec :: CInt)
(#poke struct tm,tm_min ) p_tm (fromIntegral min :: CInt)
(#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt)
(#poke struct tm,tm_mday) p_tm (fromIntegral mday :: CInt)
(#poke struct tm,tm_mon ) p_tm (fromIntegral (mon-1) :: CInt)
(#poke struct tm,tm_year ) p_tm (fromIntegral (year-1900) :: CInt)
(#poke struct tm,tm_isdst) p_tm (-1 :: CInt)
t <- mktime p_tm
return (TOD (fromIntegral t) 0)
foreign import ccall unsafe mktime :: Ptr () -> IO CTime
instance SqlBind ClockTime where
fromSqlValue SqlTime s = case readP_to_S getTime s of { [(x,_)] -> Just x }
where
getTime :: ReadP ClockTime
getTime = do
hour <- readS_to_P reads
satisfy (==':')
minutes <- readS_to_P reads
satisfy (==':')
seconds <- readS_to_P reads
return (mkClockTime 1970 0 1 hour minutes seconds)
fromSqlValue SqlDate s = case readP_to_S getDate s of { [(x,_)] -> Just x }
where
getDate :: ReadP ClockTime
getDate = do
year <- readS_to_P reads
satisfy (=='-')
month <- readS_to_P reads
satisfy (=='-')
day <- readS_to_P reads
return (mkClockTime year month day 0 0 0)
fromSqlValue SqlDateTime s = case readP_to_S getTimeStamp s of { [(x,_)] -> Just x }
where
getTimeStamp :: ReadP ClockTime
getTimeStamp = do
year <- readS_to_P reads
satisfy (=='-')
month <- readS_to_P reads
satisfy (=='-')
day <- readS_to_P reads
skipSpaces
hour <- readS_to_P reads
satisfy (==':')
minutes <- readS_to_P reads
satisfy (==':')
seconds <- readS_to_P reads
return (mkClockTime year month day hour minutes seconds)
fromSqlValue SqlTimeStamp s =
let
[year,month,day,hour,minutes,seconds] = parts [4,2,2,2,2,2] s
parts [] xs = []
parts (ix:ixs) xs = part ix 0 xs
where
part 0 n xs = n : parts ixs xs
part k n (x:xs) = part (k-1) (n*10 + (ord x - ord '0')) xs
in
Just (mkClockTime year month day hour minutes seconds)
fromSqlValue _ s = Nothing
toSqlValue ct = '\'' : (shows (ctYear t) .
score .
shows (fromEnum (ctMonth t)) .
score .
shows (ctDay t) .
space .
shows (ctHour t) .
colon .
shows (ctMin t) .
colon .
shows (ctSec t)) "'"
where
t = toUTCTime ct
score = showChar '-'
space = showChar ' '
colon = showChar ':'
getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
getFieldValueMB (Statement {currRow=currRow, fields=fieldDefs}) name = do
row <- readIORef currRow
let (sqlType,nullable,colNumber) = findFieldInfo name fieldDefs 0
pValue <- peekElemOff row colNumber
if pValue == nullPtr
then return Nothing
else do
value <- peekCString pValue
case fromSqlValue sqlType value of
Just v -> return (Just v)
Nothing -> throwDyn (SqlBadTypeCast name sqlType)
getFieldValue :: SqlBind a => Statement -> String -> IO a
getFieldValue stmt name = do
mb_v <- getFieldValueMB stmt name
case mb_v of
Nothing -> throwDyn (SqlFetchNull name)
Just a -> return a
getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a
getFieldValue' stmt name def = do
mb_v <- getFieldValueMB stmt name
return (case mb_v of { Nothing -> def; Just a -> a })
getFieldValueType :: Statement -> String -> (SqlType, Bool)
getFieldValueType stmt name = (sqlType, nullable)
where
(sqlType,nullable,colNumber) = findFieldInfo name (fields stmt) 1
getFieldsTypes :: Statement -> [(String, SqlType, Bool)]
getFieldsTypes = fields
findFieldInfo :: String -> [FieldDef] -> Int -> (SqlType,Bool,Int)
findFieldInfo name [] colNumber = error ("Undefined column name \"" ++ name ++ "\"")
findFieldInfo name (fieldDef@(name',sqlType,nullable):fields) colNumber
| name == name' = (sqlType,nullable,colNumber)
| otherwise = findFieldInfo name fields (colNumber+1)
-----------------------------------------------------------------------------------------
-- helpers
-----------------------------------------------------------------------------------------
forEachRow :: (Statement -> s -> IO s) -> Statement -> s -> IO s
forEachRow f stmt s = do
success <- fetch stmt
if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s
forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()
forEachRow' f stmt = do
success <- fetch stmt
if success then f stmt >> forEachRow' f stmt else closeStatement stmt
collectRows :: (Statement -> IO a) -> Statement -> IO [a]
collectRows f stmt = loop
where
loop = do
success <- fetch stmt
if success
then do
x <- f stmt
xs <- loop
return (x:xs)
else closeStatement stmt >> return []
|
|
From: <kr_...@us...> - 2003-09-07 09:19:13
|
Update of /cvsroot/htoolkit/HSQL/src/PostgreSQL In directory sc8-pr-cvs1:/tmp/cvs-serv26918/PostgreSQL Removed Files: HSQL.hsc Log Message: Remove old files --- HSQL.hsc DELETED --- |
|
From: <kr_...@us...> - 2003-09-07 09:19:13
|
Update of /cvsroot/htoolkit/HSQL/src/ODBC In directory sc8-pr-cvs1:/tmp/cvs-serv26918/ODBC Removed Files: HSQL.hsc HSQLStructs.h Log Message: Remove old files --- HSQL.hsc DELETED --- --- HSQLStructs.h DELETED --- |
|
From: <kr_...@us...> - 2003-09-07 09:19:13
|
Update of /cvsroot/htoolkit/HSQL/src/MySQL In directory sc8-pr-cvs1:/tmp/cvs-serv26918/MySQL Removed Files: HSQL.hsc Log Message: Remove old files --- HSQL.hsc DELETED --- |
|
From: <kr_...@us...> - 2003-09-07 09:13:41
|
Update of /cvsroot/htoolkit/HSQL/MySQL In directory sc8-pr-cvs1:/tmp/cvs-serv26186/MySQL Log Message: Directory /cvsroot/htoolkit/HSQL/MySQL added to the repository |
|
From: <kr_...@us...> - 2003-09-07 09:09:51
|
Update of /cvsroot/htoolkit/HSQL
In directory sc8-pr-cvs1:/tmp/cvs-serv25631
Modified Files:
configure.ac
Log Message:
Add additional test for PostgreSQL
Index: configure.ac
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/configure.ac,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** configure.ac 6 Sep 2003 22:57:23 -0000 1.4
--- configure.ac 7 Sep 2003 09:09:47 -0000 1.5
***************
*** 180,183 ****
--- 180,184 ----
AC_CHECK_HEADER(libpq-fe.h,,AC_MSG_ERROR([libpq-fe.h header not found]))
+ AC_CHECK_HEADER(postgres.h,,AC_MSG_ERROR([postgres.h header not found]))
AC_CHECK_LIB(pq,PQsetdbLogin,,AC_MSG_ERROR([libpq.a library not found]))
fi
***************
*** 191,195 ****
if test "$MYSQL_CONFIG" = "" || test ! -f $MYSQL_CONFIG; then
! AC_MSG_ERROR([mysql_config is required to build PostgreSQL binding])
fi
--- 192,196 ----
if test "$MYSQL_CONFIG" = "" || test ! -f $MYSQL_CONFIG; then
! AC_MSG_ERROR([mysql_config is required to build MySQL binding])
fi
|
|
From: <kr_...@us...> - 2003-09-06 22:57:36
|
Update of /cvsroot/htoolkit/HSQL
In directory sc8-pr-cvs1:/tmp/cvs-serv12616
Modified Files:
configure.ac
Log Message:
better support for PostgreSQL for Windows
Index: configure.ac
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/configure.ac,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** configure.ac 6 Sep 2003 19:59:06 -0000 1.3
--- configure.ac 6 Sep 2003 22:57:23 -0000 1.4
***************
*** 167,177 ****
fi
case $ac_cv_target_alias in
i[[3456]]86-*-cygwin*|i[[3456]]86-*-mingw32*)
LDFLAGS="$LDFLAGS -L$(cygpath -m `$PG_CONFIG --libdir`)"
! CPPFLAGS="$CPPFLAGS -I$(cygpath -m /usr/include) -I$(cygpath -m `$PG_CONFIG --includedir`)"
;;
*) LDFLAGS="$LDFLAGS -L`$PG_CONFIG --libdir`"
! CPPFLAGS="$CPPFLAGS -I`$PG_CONFIG --includedir` -I`$PG_CONFIG --includedir`/server"
;;
esac
--- 167,179 ----
fi
+ incdir=`$PG_CONFIG --includedir`
case $ac_cv_target_alias in
i[[3456]]86-*-cygwin*|i[[3456]]86-*-mingw32*)
LDFLAGS="$LDFLAGS -L$(cygpath -m `$PG_CONFIG --libdir`)"
! incdir=$(cygpath -m $incdir)
! CPPFLAGS="$CPPFLAGS -I$(cygpath -m /usr/include) -I$incdir -I$incdir/server"
;;
*) LDFLAGS="$LDFLAGS -L`$PG_CONFIG --libdir`"
! CPPFLAGS="$CPPFLAGS -I$incdir -I$incdir/server"
;;
esac
|
|
From: <kr_...@us...> - 2003-09-06 22:48:49
|
Update of /cvsroot/htoolkit/HSQL/PostgreSQL In directory sc8-pr-cvs1:/tmp/cvs-serv11308/PostgreSQL Modified Files: HSQL.hsc Log Message: formatting Index: HSQL.hsc =================================================================== RCS file: /cvsroot/htoolkit/HSQL/PostgreSQL/HSQL.hsc,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** HSQL.hsc 6 Sep 2003 21:50:28 -0000 1.2 --- HSQL.hsc 6 Sep 2003 22:48:00 -0000 1.3 *************** *** 286,303 **** class SqlBind a where fromSqlValue :: SqlType -> String -> Maybe a ! toSqlValue :: a -> String instance SqlBind Int where ! fromSqlValue SqlInteger s = Just (read s) fromSqlValue SqlSmallInt s = Just (read s) ! fromSqlValue _ _ = Nothing toSqlValue s = show s instance SqlBind Integer where ! fromSqlValue SqlInteger s = Just (read s) fromSqlValue SqlSmallInt s = Just (read s) ! fromSqlValue SqlBigInt s = Just (read s) ! fromSqlValue _ _ = Nothing toSqlValue s = show s --- 286,303 ---- class SqlBind a where fromSqlValue :: SqlType -> String -> Maybe a ! toSqlValue :: a -> String instance SqlBind Int where ! fromSqlValue SqlInteger s = Just (read s) fromSqlValue SqlSmallInt s = Just (read s) ! fromSqlValue _ _ = Nothing toSqlValue s = show s instance SqlBind Integer where ! fromSqlValue SqlInteger s = Just (read s) fromSqlValue SqlSmallInt s = Just (read s) ! fromSqlValue SqlBigInt s = Just (read s) ! fromSqlValue _ _ = Nothing toSqlValue s = show s *************** *** 332,340 **** unsafePerformIO $ do allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do ! (#poke struct tm,tm_sec ) p_tm (fromIntegral sec :: CInt) ! (#poke struct tm,tm_min ) p_tm (fromIntegral min :: CInt) (#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt) ! (#poke struct tm,tm_mday) p_tm (fromIntegral mday :: CInt) ! (#poke struct tm,tm_mon ) p_tm (fromIntegral (mon-1) :: CInt) (#poke struct tm,tm_year ) p_tm (fromIntegral (year-1900) :: CInt) (#poke struct tm,tm_isdst) p_tm (-1 :: CInt) --- 332,340 ---- unsafePerformIO $ do allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do ! (#poke struct tm,tm_sec ) p_tm (fromIntegral sec :: CInt) ! (#poke struct tm,tm_min ) p_tm (fromIntegral min :: CInt) (#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt) ! (#poke struct tm,tm_mday ) p_tm (fromIntegral mday :: CInt) ! (#poke struct tm,tm_mon ) p_tm (fromIntegral (mon-1) :: CInt) (#poke struct tm,tm_year ) p_tm (fromIntegral (year-1900) :: CInt) (#poke struct tm,tm_isdst) p_tm (-1 :: CInt) *************** *** 358,362 **** getTime :: ReadP ClockTime getTime = do ! hour <- readS_to_P reads char ':' minutes <- readS_to_P reads --- 358,362 ---- getTime :: ReadP ClockTime getTime = do ! hour <- readS_to_P reads char ':' minutes <- readS_to_P reads *************** *** 370,374 **** getTime :: ReadP ClockTime getTime = do ! hour <- readS_to_P reads char ':' minutes <- readS_to_P reads --- 370,374 ---- getTime :: ReadP ClockTime getTime = do ! hour <- readS_to_P reads char ':' minutes <- readS_to_P reads *************** *** 381,389 **** getDate :: ReadP ClockTime getDate = do ! year <- readS_to_P reads satisfy (=='-') month <- readS_to_P reads ! satisfy (=='-') ! day <- readS_to_P reads return (mkClockTime year month day 0 0 0 currTZ) --- 381,389 ---- getDate :: ReadP ClockTime getDate = do ! year <- readS_to_P reads satisfy (=='-') month <- readS_to_P reads ! satisfy (=='-') ! day <- readS_to_P reads return (mkClockTime year month day 0 0 0 currTZ) *************** *** 392,407 **** getTimeStamp :: ReadP ClockTime getTimeStamp = do ! year <- readS_to_P reads satisfy (=='-') month <- readS_to_P reads ! satisfy (=='-') ! day <- readS_to_P reads skipSpaces ! hour <- readS_to_P reads ! satisfy (==':') minutes <- readS_to_P reads satisfy (==':') seconds <- readS_to_P reads ! tz <- parseTZ return (mkClockTime year month day hour minutes seconds (tz*3600)) --- 392,407 ---- getTimeStamp :: ReadP ClockTime getTimeStamp = do ! year <- readS_to_P reads satisfy (=='-') month <- readS_to_P reads ! satisfy (=='-') ! day <- readS_to_P reads skipSpaces ! hour <- readS_to_P reads ! satisfy (==':') minutes <- readS_to_P reads satisfy (==':') seconds <- readS_to_P reads ! tz <- parseTZ return (mkClockTime year month day hour minutes seconds (tz*3600)) *************** *** 581,585 **** findFieldInfo name (fieldDef@(name',sqlType):fields) colNumber | name == name' = (sqlType,colNumber) ! | otherwise = findFieldInfo name fields (colNumber+1) --- 581,585 ---- findFieldInfo name (fieldDef@(name',sqlType):fields) colNumber | name == name' = (sqlType,colNumber) ! | otherwise = findFieldInfo name fields (colNumber+1) |
|
From: <kr_...@us...> - 2003-09-06 22:44:33
|
Update of /cvsroot/htoolkit/HSQL/ODBC
In directory sc8-pr-cvs1:/tmp/cvs-serv10736/ODBC
Modified Files:
HSQL.hsc
Log Message:
Add better support for sql types
Index: HSQL.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/ODBC/HSQL.hsc,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** HSQL.hsc 5 Sep 2003 21:44:10 -0000 1.1
--- HSQL.hsc 6 Sep 2003 22:44:13 -0000 1.2
***************
*** 102,110 ****
data SqlType
! = SqlChar Int
! | SqlVarChar Int
! | SqlLongVarChar Int
! | SqlDecimal Int Int
! | SqlNumeric Int Int
| SqlSmallInt
| SqlInteger
--- 102,110 ----
data SqlType
! = SqlChar Int
! | SqlVarChar Int
! | SqlLongVarChar Int
! | SqlDecimal Int Int
! | SqlNumeric Int Int
| SqlSmallInt
| SqlInteger
***************
*** 114,120 ****
| SqlTinyInt
| SqlBigInt
! | SqlBinary Int
! | SqlVarBinary Int
! | SqlLongVarBinary Int
| SqlDate
| SqlTime
--- 114,120 ----
| SqlTinyInt
| SqlBigInt
! | SqlBinary Int
! | SqlVarBinary Int
! | SqlLongVarBinary Int
| SqlDate
| SqlTime
***************
*** 124,130 ****
data SqlError
= SqlError
! { seState :: String
! , seNativeError :: Int
! , seErrorMsg :: String
}
| SqlNoData
--- 124,130 ----
data SqlError
= SqlError
! { seState :: String
! , seNativeError :: Int
! , seErrorMsg :: String
}
| SqlNoData
***************
*** 132,136 ****
| SqlStillExecuting
| SqlNeedData
! deriving Show
-----------------------------------------------------------------------------------------
--- 132,143 ----
| SqlStillExecuting
| SqlNeedData
! | SqlBadTypeCast
! { seFieldName :: String
! , seFieldType :: SqlType
! }
! | SqlFetchNull
! { seFieldName :: String
! }
! deriving (Show, Typeable)
-----------------------------------------------------------------------------------------
***************
*** 138,147 ****
-----------------------------------------------------------------------------------------
- {-# NOINLINE sqlErrorTy #-}
- sqlErrorTy = mkAppTy (mkTyCon "SqlError") []
-
- instance Typeable SqlError where
- typeOf x = sqlErrorTy
-
catchSql :: IO a -> (SqlError -> IO a) -> IO a
catchSql = catchDyn
--- 145,148 ----
***************
*** 332,367 ****
class SqlBind a where
! getSqlValue :: SqlType -> Ptr () -> Int -> IO a
instance SqlBind Int where
! getSqlValue SqlInteger ptr size = peek (castPtr ptr)
! getSqlValue SqlSmallInt ptr size = do
(n :: Int16) <- peek (castPtr ptr)
! return (fromIntegral n)
instance SqlBind Integer where
! getSqlValue SqlInteger ptr size = do
(n :: Int32) <- peek (castPtr ptr)
! return (fromIntegral n)
! getSqlValue SqlSmallInt ptr size = do
(n :: Int16) <- peek (castPtr ptr)
! return (fromIntegral n)
! getSqlValue SqlBigInt ptr size = do
str <- peekCStringLen (castPtr ptr, size)
! return (read str)
instance SqlBind String where
! getSqlValue (SqlChar _) ptr size = peekCStringLen (castPtr ptr, size)
! getSqlValue (SqlVarChar _) ptr size = peekCStringLen (castPtr ptr, size)
! getSqlValue (SqlLongVarChar _) ptr size = peekCStringLen (castPtr ptr, size)
instance SqlBind Double where
! getSqlValue (SqlDecimal _ _) ptr size = peek (castPtr ptr)
! getSqlValue (SqlNumeric _ _) ptr size = peek (castPtr ptr)
! getSqlValue SqlDouble ptr size = peek (castPtr ptr)
! getSqlValue SqlReal ptr size = peek (castPtr ptr)
instance SqlBind ClockTime where
! getSqlValue SqlDate ptr size = allocaBytes (#const sizeof(struct tm)) $ \p_tm -> do
(year :: SQLSMALLINT) <- (#peek TIMESTAMP_STRUCT, year) ptr
(#poke struct tm,tm_year ) p_tm (fromIntegral (year-1900) :: CInt)
--- 333,384 ----
class SqlBind a where
! fromSqlValue :: SqlType -> Ptr () -> Int -> IO (Maybe a)
! toSqlValue :: a -> String
instance SqlBind Int where
! fromSqlValue SqlInteger ptr size = fmap Just $ peek (castPtr ptr)
! fromSqlValue SqlSmallInt ptr size = do
(n :: Int16) <- peek (castPtr ptr)
! return (Just (fromIntegral n))
! fromSqlValue _ _ _ = return Nothing
!
! toSqlValue val = show val
instance SqlBind Integer where
! fromSqlValue SqlInteger ptr size = do
(n :: Int32) <- peek (castPtr ptr)
! return (Just (fromIntegral n))
! fromSqlValue SqlSmallInt ptr size = do
(n :: Int16) <- peek (castPtr ptr)
! return (Just (fromIntegral n))
! fromSqlValue SqlBigInt ptr size = do
str <- peekCStringLen (castPtr ptr, size)
! return (Just (read str))
! fromSqlValue _ _ _ = return Nothing
!
! toSqlValue val = show val
instance SqlBind String where
! fromSqlValue (SqlChar _) ptr size = fmap Just $ peekCStringLen (castPtr ptr, size)
! fromSqlValue (SqlVarChar _) ptr size = fmap Just $ peekCStringLen (castPtr ptr, size)
! fromSqlValue (SqlLongVarChar _) ptr size = fmap Just $ peekCStringLen (castPtr ptr, size)
! fromSqlValue _ _ _ = return Nothing
!
! toSqlValue s = '\'' : foldr mapChar "'" s
! where
! mapChar '\'' s = '\'':'\'':s
! mapChar c s = c:s
instance SqlBind Double where
! fromSqlValue (SqlDecimal _ _) ptr size = fmap Just $ peek (castPtr ptr)
! fromSqlValue (SqlNumeric _ _) ptr size = fmap Just $ peek (castPtr ptr)
! fromSqlValue SqlDouble ptr size = fmap Just $ peek (castPtr ptr)
! fromSqlValue SqlReal ptr size = fmap Just $ peek (castPtr ptr)
! fromSqlValue _ _ _ = return Nothing
!
! toSqlValue val = show val
instance SqlBind ClockTime where
! fromSqlValue SqlDate ptr size = allocaBytes (#const sizeof(struct tm)) $ \p_tm -> do
(year :: SQLSMALLINT) <- (#peek TIMESTAMP_STRUCT, year) ptr
(#poke struct tm,tm_year ) p_tm (fromIntegral (year-1900) :: CInt)
***************
*** 379,384 ****
(#poke struct tm,tm_isdst) p_tm (-1 :: CInt)
t <- mktime p_tm
! return (TOD (fromIntegral t) (fromIntegral fraction*1000))
! foreign import ccall unsafe mktime :: Ptr () -> IO CTime
getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
--- 396,420 ----
(#poke struct tm,tm_isdst) p_tm (-1 :: CInt)
t <- mktime p_tm
! return (Just (TOD (fromIntegral t) (fromIntegral fraction*1000)))
! fromSqlValue _ _ _ = return Nothing
!
! toSqlValue ct = '\'' : (shows (ctYear t) .
! score .
! shows (ctMonth t) .
! score .
! shows (ctDay t) .
! space .
! shows (ctHour t) .
! colon .
! shows (ctMin t) .
! colon .
! shows (ctSec t)) "'"
! where
! t = toUTCTime ct
! score = showChar '-'
! space = showChar ' '
! colon = showChar ':'
!
! foreign import ccall unsafe mktime :: Ptr () -> IO CTime
getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
***************
*** 390,397 ****
if len_or_ind == (#const SQL_NULL_DATA)
then return Nothing
! else fmap Just $
! (if res == (#const SQL_SUCCESS_WITH_INFO)
then getLongData len_or_ind
! else getSqlValue sqlType dataBuffer (fromIntegral len_or_ind))
where
(sqlType,nullable,colNumber) = findFieldInfo name fields 1
--- 426,436 ----
if len_or_ind == (#const SQL_NULL_DATA)
then return Nothing
! else do
! mb_value <- (if res == (#const SQL_SUCCESS_WITH_INFO)
then getLongData len_or_ind
! else fromSqlValue sqlType dataBuffer (fromIntegral len_or_ind))
! case mb_value of
! Just value -> return (Just value)
! Nothing -> throwDyn (SqlBadTypeCast name sqlType)
where
(sqlType,nullable,colNumber) = findFieldInfo name fields 1
***************
*** 404,408 ****
handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
(len_or_ind :: SQLINTEGER) <- peek (castPtr buffer)
! r <- getSqlValue sqlType dataBuffer (fromIntegral len_or_ind)
free buffer
return r
--- 443,447 ----
handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
(len_or_ind :: SQLINTEGER) <- peek (castPtr buffer)
! r <- fromSqlValue sqlType dataBuffer (fromIntegral len_or_ind)
free buffer
return r
***************
*** 432,437 ****
mb_v <- getFieldValueMB stmt name
case mb_v of
! Nothing -> fail ("Column \"" ++ name ++ "\" has null value")
! Just a -> return a
getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a
--- 471,476 ----
mb_v <- getFieldValueMB stmt name
case mb_v of
! Nothing -> throwDyn (SqlFetchNull name)
! Just a -> return a
getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a
|
|
From: <kr_...@us...> - 2003-09-06 21:52:51
|
Update of /cvsroot/htoolkit/HSQL In directory sc8-pr-cvs1:/tmp/cvs-serv1545 Modified Files: Makefile Log Message: bugfix: force ghc-pkg to rebuild GHCi libraries each time when install new *.a library Index: Makefile =================================================================== RCS file: /cvsroot/htoolkit/HSQL/Makefile,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** Makefile 6 Sep 2003 19:59:06 -0000 1.3 --- Makefile 6 Sep 2003 21:52:42 -0000 1.4 *************** *** 58,61 **** --- 58,62 ---- $(INSTALL) -c $$i $(prefix)/imports/Database/`dirname $$i`; \ done + rm -f $(prefix)/HSsql.o $(GHC_PKG) -u -g -i hsql.pkg if test -f doc/index.html; then \ |
|
From: <kr_...@us...> - 2003-09-06 21:50:45
|
Update of /cvsroot/htoolkit/HSQL/PostgreSQL
In directory sc8-pr-cvs1:/tmp/cvs-serv1131/PostgreSQL
Modified Files:
HSQL.hsc
Log Message:
Add support for inet, cidr and macaddr sql types
Index: HSQL.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/PostgreSQL/HSQL.hsc,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** HSQL.hsc 6 Sep 2003 19:59:06 -0000 1.1
--- HSQL.hsc 6 Sep 2003 21:50:28 -0000 1.2
***************
*** 33,36 ****
--- 33,37 ----
, collectRows -- :: (Statement -> IO s) -> Statement -> IO [s]
, Point(..), Line(..), Path(..), Box(..), Circle(..), Polygon(..)
+ , INetAddr(..), MacAddr(..)
) where
***************
*** 38,41 ****
--- 39,43 ----
import Data.Dynamic
import Data.IORef
+ import Data.Char
import Foreign
import Foreign.C
***************
*** 46,49 ****
--- 48,52 ----
import Text.ParserCombinators.ReadP
import Text.Read
+ import Numeric
# include <time.h>
***************
*** 418,422 ****
where
t = toUTCTime ct
! score = showChar '.'
space = showChar ' '
colon = showChar ':'
--- 421,425 ----
where
t = toUTCTime ct
! score = showChar '-'
space = showChar ' '
colon = showChar ':'
***************
*** 477,480 ****
--- 480,545 ----
toSqlValue (Circle (Point x y) r) = "'<" ++ show (x,y) ++ "," ++ show r ++ "'>"
+
+ data INetAddr = INetAddr Int Int Int Int Int deriving (Eq,Show)
+
+ instance SqlBind INetAddr where
+ fromSqlValue t s
+ | t == SqlINetAddr || t == SqlCIDRAddr =
+ case readNum s of
+ (x1,s) -> case readNum s of
+ (x2,s) -> case readNum s of
+ (x3,s) -> case readNum s of
+ (x4,s) -> case readNum s of
+ (mask,_) -> Just (INetAddr x1 x2 x3 x4 mask)
+ | otherwise = Nothing
+ where
+ readNum s = case readDec s of
+ [(x,'.':s)] -> (x,s)
+ [(x,'/':s)] -> (x,s)
+ [(x,"")] -> (x,"")
+ _ -> (0,"")
+
+ toSqlValue (INetAddr x1 x2 x3 x4 mask) = '\'' :
+ (shows x1 .
+ dot .
+ shows x2.
+ dot .
+ shows x3 .
+ dot .
+ shows x4 .
+ slash .
+ shows mask) "'"
+ where
+ dot = showChar '.'
+ slash = showChar '/'
+
+ data MacAddr = MacAddr Int Int Int Int Int Int deriving (Eq,Show)
+
+ instance SqlBind MacAddr where
+ fromSqlValue SqlMacAddr s =
+ case readHex s of
+ [(x1,':':s)] -> case readHex s of
+ [(x2,':':s)] -> case readHex s of
+ [(x3,':':s)] -> case readHex s of
+ [(x4,':':s)] -> case readHex s of
+ [(x5,':':s)] -> case readHex s of
+ [(x6,_)] -> Just (MacAddr x1 x2 x3 x4 x5 x6)
+ fromSqlValue _ _ = Nothing
+
+ toSqlValue (MacAddr x1 x2 x3 x4 x5 x6) = '\'' :
+ (showHex x1 .
+ colon .
+ showHex x2 .
+ colon .
+ showHex x3 .
+ colon .
+ showHex x4 .
+ colon .
+ showHex x5 .
+ colon .
+ showHex x6) "'"
+ where
+ colon = showChar ':'
+ showHex = showIntAtBase 16 intToDigit
getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
|
|
From: <kr_...@us...> - 2003-09-06 19:59:10
|
Update of /cvsroot/htoolkit/HSQL/PostgreSQL
In directory sc8-pr-cvs1:/tmp/cvs-serv11008/PostgreSQL
Added Files:
HSQL.hsc
Log Message:
Support for PostgreSQL. The new implementation has better support for Sql<->Haskell data translation
--- NEW FILE: HSQL.hsc ---
-----------------------------------------------------------------------------------------
{-| Module : Database.PostgreSQL.HSQL
Copyright : (c) Krasimir Angelov 2003
License : BSD-style
Maintainer : ka2...@ya...
Stability : provisional
Portability : portable
The module provides interface to PostgreSQL database
-}
-----------------------------------------------------------------------------------------
module Database.PostgreSQL.HSQL
( SqlBind(..), SqlError(..), SqlType(..), Connection, Statement
, catchSql -- :: IO a -> (SqlError -> IO a) -> IO a
, handleSql -- :: (SqlError -> IO a) -> IO a -> IO a
, sqlExceptions -- :: Exception -> Maybe SqlError
, connect -- :: String -> String -> String -> IO Connection
, disconnect -- :: Connection -> IO ()
, execute -- :: Connection -> String -> IO Statement
, query -- :: Connection -> String -> IO ()
, closeStatement -- :: Statement -> IO ()
, fetch -- :: Statement -> IO Bool
, inTransaction -- :: Connection -> (Connection -> IO a) -> IO a
, getFieldValueMB -- :: SqlBind a => Statement -> String -> IO (Maybe a)
, getFieldValue -- :: SqlBind a => Statement -> String -> IO a
, getFieldValue' -- :: SqlBind a => Statement -> String -> a -> IO a
, getFieldValueType -- :: Statement -> String -> (SqlType, Bool)
, getFieldsTypes -- :: Statement -> [(String, SqlType, Bool)]
, forEachRow -- :: (Statement -> s -> IO s) -> Statement -> s -> IO s
, forEachRow' -- :: (Statement -> IO ()) -> Statement -> IO ()
, collectRows -- :: (Statement -> IO s) -> Statement -> IO [s]
, Point(..), Line(..), Path(..), Box(..), Circle(..), Polygon(..)
) where
import Data.Dynamic
import Data.IORef
import Foreign
import Foreign.C
import Control.Exception (throwDyn, catchDyn, dynExceptions, Exception(..))
import Control.Monad(when,unless,mplus)
import System.Time
import System.IO.Unsafe
import Text.ParserCombinators.ReadP
import Text.Read
# include <time.h>
#include <libpq-fe.h>
#include <postgres.h>
#include <catalog/pg_type.h>
type PGconn = Ptr ()
type PGresult = Ptr ()
type ConnStatusType = #type ConnStatusType
type ExecStatusType = #type ExecStatusType
type Oid = #type Oid
foreign import ccall "libpq-fe.h PQsetdbLogin" pqSetdbLogin :: CString -> CString -> CString -> CString -> CString -> CString -> CString -> IO PGconn
foreign import ccall "libpq-fe.h PQstatus" pqStatus :: PGconn -> IO ConnStatusType
foreign import ccall "libpq-fe.h PQerrorMessage" pqErrorMessage :: PGconn -> IO CString
foreign import ccall "libpq-fe.h PQfinish" pqFinish :: PGconn -> IO ()
foreign import ccall "libpq-fe.h PQexec" pqExec :: PGconn -> CString -> IO PGresult
foreign import ccall "libpq-fe.h PQresultStatus" pqResultStatus :: PGresult -> IO ExecStatusType
foreign import ccall "libpq-fe.h PQresStatus" pqResStatus :: ExecStatusType -> IO CString
foreign import ccall "libpq-fe.h PQresultErrorMessage" pqResultErrorMessage :: PGresult -> IO CString
foreign import ccall "libpq-fe.h PQnfields" pgNFields :: PGresult -> IO Int
foreign import ccall "libpq-fe.h PQntuples" pqNTuples :: PGresult -> IO Int
foreign import ccall "libpq-fe.h PQfname" pgFName :: PGresult -> Int -> IO CString
foreign import ccall "libpq-fe.h PQftype" pqFType :: PGresult -> Int -> IO Oid
foreign import ccall "libpq-fe.h PQfmod" pqFMod :: PGresult -> Int -> IO Int
foreign import ccall "libpq-fe.h PQfnumber" pqFNumber :: PGresult -> CString -> IO Int
foreign import ccall "libpq-fe.h PQgetvalue" pqGetvalue :: PGresult -> Int -> Int -> IO CString
foreign import ccall "libpq-fe.h PQgetisnull" pqGetisnull :: PGresult -> Int -> Int -> IO Int
newtype Connection = Connection PGconn
data Statement
= Statement
{ pRes :: !PGresult
, tupleIndex :: IORef Int
, countTuples:: !Int
, connection :: !Connection
, fields :: ![FieldDef]
}
type FieldDef = (String, SqlType)
data SqlType
= SqlChar Int
| SqlVarChar Int
| SqlText
| SqlNumeric Int Int
| SqlSmallInt
| SqlInteger
| SqlReal
| SqlDouble
| SqlBool
| SqlBit Int
| SqlVarBit Int
| SqlTinyInt
| SqlBigInt
| SqlDate
| SqlTime
| SqlAbsTime
| SqlRelTime
| SqlTimeTZ
| SqlTimeInterval
| SqlAbsTimeInterval
| SqlTimeStamp
| SqlMoney
| SqlINetAddr
| SqlCIDRAddr
| SqlMacAddr
| SqlPoint
| SqlLSeg
| SqlPath
| SqlBox
| SqlPolygon
| SqlLine
| SqlCircle
| SqlUnknown
deriving (Eq, Show)
data SqlError
= SqlError
{ seState :: String
, seNativeError :: Int
, seErrorMsg :: String
}
| SqlNoData
| SqlBadTypeCast
{ seFieldName :: String
, seFieldType :: SqlType
}
| SqlFetchNull
{ seFieldName :: String
}
deriving (Show, Typeable)
-----------------------------------------------------------------------------------------
-- routines for handling exceptions
-----------------------------------------------------------------------------------------
catchSql :: IO a -> (SqlError -> IO a) -> IO a
catchSql = catchDyn
handleSql :: (SqlError -> IO a) -> IO a -> IO a
handleSql h f = catchDyn f h
sqlExceptions :: Exception -> Maybe SqlError
sqlExceptions e = dynExceptions e >>= fromDynamic
-----------------------------------------------------------------------------------------
-- Connect/Disconnect
-----------------------------------------------------------------------------------------
connect :: String -> String -> String -> String -> IO Connection
connect server database user authentication = do
pServer <- newCString server
pDatabase <- newCString database
pUser <- newCString user
pAuthentication <- newCString authentication
pConn <- pqSetdbLogin pServer nullPtr nullPtr nullPtr pDatabase pUser pAuthentication
free pServer
free pUser
free pAuthentication
status <- pqStatus pConn
unless (status == (#const CONNECTION_OK)) (do
errMsg <- pqErrorMessage pConn >>= peekCString
pqFinish pConn
throwDyn (SqlError {seState="C", seNativeError=fromIntegral status, seErrorMsg=errMsg}))
return (Connection pConn)
disconnect :: Connection -> IO ()
disconnect (Connection pConn) = pqFinish pConn
-----------------------------------------------------------------------------------------
-- queries
-----------------------------------------------------------------------------------------
execute :: Connection -> String -> IO ()
execute conn@(Connection pConn) sqlExpr = do
pRes <- withCString sqlExpr (pqExec pConn)
when (pRes==nullPtr) (do
errMsg <- pqErrorMessage pConn >>= peekCString
throwDyn (SqlError {seState="E", seNativeError=(#const PGRES_FATAL_ERROR), seErrorMsg=errMsg}))
status <- pqResultStatus pRes
unless (status == (#const PGRES_COMMAND_OK) || status == (#const PGRES_TUPLES_OK)) (do
errMsg <- pqResultErrorMessage pRes >>= peekCString
throwDyn (SqlError {seState="E", seNativeError=fromIntegral status, seErrorMsg=errMsg}))
return ()
query :: Connection -> String -> IO Statement
query conn@(Connection pConn) query = do
pRes <- withCString query (pqExec pConn)
when (pRes==nullPtr) (do
errMsg <- pqErrorMessage pConn >>= peekCString
throwDyn (SqlError {seState="E", seNativeError=(#const PGRES_FATAL_ERROR), seErrorMsg=errMsg}))
status <- pqResultStatus pRes
unless (status == (#const PGRES_COMMAND_OK) || status == (#const PGRES_TUPLES_OK)) (do
errMsg <- pqResultErrorMessage pRes >>= peekCString
throwDyn (SqlError {seState="E", seNativeError=fromIntegral status, seErrorMsg=errMsg}))
defs <- if status == (#const PGRES_TUPLES_OK) then pgNFields pRes >>= getFieldDefs pRes 0 else return []
countTuples <- pqNTuples pRes;
tupleIndex <- newIORef (-1)
return (Statement {pRes=pRes, connection=conn, fields=defs, countTuples=countTuples, tupleIndex=tupleIndex})
where
getFieldDefs pRes i n
| i >= n = return []
| otherwise = do
name <- pgFName pRes i >>= peekCString
dataType <- pqFType pRes i
modifier <- pqFMod pRes i
defs <- getFieldDefs pRes (i+1) n
return ((name,mkSqlType dataType modifier):defs)
mkSqlType :: Oid -> Int -> SqlType
mkSqlType (#const BPCHAROID) size = SqlChar (size-4)
mkSqlType (#const VARCHAROID) size = SqlVarChar (size-4)
mkSqlType (#const NAMEOID) size = SqlVarChar 31
mkSqlType (#const TEXTOID) size = SqlText
mkSqlType (#const NUMERICOID) size = SqlNumeric ((size-4) `div` 0x10000) ((size-4) `mod` 0x10000)
mkSqlType (#const INT2OID) size = SqlSmallInt
mkSqlType (#const INT4OID) size = SqlInteger
mkSqlType (#const FLOAT4OID) size = SqlReal
mkSqlType (#const FLOAT8OID) size = SqlDouble
mkSqlType (#const BOOLOID) size = SqlBool
mkSqlType (#const BITOID) size = SqlBit size
mkSqlType (#const VARBITOID) size = SqlVarBit size
mkSqlType (#const BYTEAOID) size = SqlTinyInt
mkSqlType (#const INT8OID) size = SqlBigInt
mkSqlType (#const DATEOID) size = SqlDate
mkSqlType (#const TIMEOID) size = SqlTime
mkSqlType (#const TIMETZOID) size = SqlTimeTZ
mkSqlType (#const ABSTIMEOID) size = SqlAbsTime
mkSqlType (#const RELTIMEOID) size = SqlRelTime
mkSqlType (#const INTERVALOID) size = SqlTimeInterval
mkSqlType (#const TINTERVALOID) size = SqlAbsTimeInterval
mkSqlType (#const TIMESTAMPOID) size = SqlTimeStamp
mkSqlType (#const CASHOID) size = SqlMoney
mkSqlType (#const INETOID) size = SqlINetAddr
mkSqlType (#const 829) size = SqlMacAddr -- hack
mkSqlType (#const CIDROID) size = SqlCIDRAddr
mkSqlType (#const POINTOID) size = SqlPoint
mkSqlType (#const LSEGOID) size = SqlLSeg
mkSqlType (#const PATHOID) size = SqlPath
mkSqlType (#const BOXOID) size = SqlBox
mkSqlType (#const POLYGONOID) size = SqlPolygon
mkSqlType (#const LINEOID) size = SqlLine
mkSqlType (#const CIRCLEOID) size = SqlCircle
mkSqlType (#const UNKNOWNOID) size = SqlUnknown
fetch :: Statement -> IO Bool
fetch (Statement {countTuples=countTuples, tupleIndex=tupleIndex}) = do
index <- readIORef tupleIndex
let index' = index+1
if (index' >= countTuples)
then return False
else writeIORef tupleIndex index' >> return True
closeStatement :: Statement -> IO ()
closeStatement _ = return ()
-----------------------------------------------------------------------------------------
-- transactions
-----------------------------------------------------------------------------------------
inTransaction :: Connection -> (Connection -> IO a) -> IO a
inTransaction conn action = do
execute conn "begin"
r <- catchSql (action conn) (\err -> execute conn "rollback" >>= throwDyn err)
execute conn "commit"
return r
-----------------------------------------------------------------------------------------
-- binding
-----------------------------------------------------------------------------------------
class SqlBind a where
fromSqlValue :: SqlType -> String -> Maybe a
toSqlValue :: a -> String
instance SqlBind Int where
fromSqlValue SqlInteger s = Just (read s)
fromSqlValue SqlSmallInt s = Just (read s)
fromSqlValue _ _ = Nothing
toSqlValue s = show s
instance SqlBind Integer where
fromSqlValue SqlInteger s = Just (read s)
fromSqlValue SqlSmallInt s = Just (read s)
fromSqlValue SqlBigInt s = Just (read s)
fromSqlValue _ _ = Nothing
toSqlValue s = show s
instance SqlBind String where
fromSqlValue _ = Just
toSqlValue s = '\'' : foldr mapChar "'" s
where
mapChar '\'' s = '\\':'\'':s
mapChar '\n' s = '\\':'n':s
mapChar '\r' s = '\\':'r':s
mapChar '\t' s = '\\':'t':s
mapChar c s = c:s
instance SqlBind Bool where
fromSqlValue SqlBool s = Just (s == "t")
fromSqlValue _ _ = Nothing
toSqlValue True = "'t'"
toSqlValue False = "'f'"
instance SqlBind Double where
fromSqlValue (SqlNumeric _ _) s = Just (read s)
fromSqlValue SqlDouble s = Just (read s)
fromSqlValue SqlReal s = Just (read s)
fromSqlValue _ _ = Nothing
toSqlValue d = show d
mkClockTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> ClockTime
mkClockTime year mon mday hour min sec tz =
unsafePerformIO $ do
allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do
(#poke struct tm,tm_sec ) p_tm (fromIntegral sec :: CInt)
(#poke struct tm,tm_min ) p_tm (fromIntegral min :: CInt)
(#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt)
(#poke struct tm,tm_mday) p_tm (fromIntegral mday :: CInt)
(#poke struct tm,tm_mon ) p_tm (fromIntegral (mon-1) :: CInt)
(#poke struct tm,tm_year ) p_tm (fromIntegral (year-1900) :: CInt)
(#poke struct tm,tm_isdst) p_tm (-1 :: CInt)
t <- mktime p_tm
return (TOD (fromIntegral t + fromIntegral (tz-currTZ)) 0)
foreign import ccall unsafe mktime :: Ptr () -> IO CTime
{-# NOINLINE currTZ #-}
currTZ :: Int
currTZ = ctTZ (unsafePerformIO (getClockTime >>= toCalendarTime)) -- Hack
parseTZ :: ReadP Int
parseTZ = (char '+' >> readS_to_P reads) `mplus` (char '-' >> fmap negate (readS_to_P reads))
f_read :: ReadP a -> String -> Maybe a
f_read f s = case readP_to_S f s of {[(x,_)] -> Just x}
instance SqlBind ClockTime where
fromSqlValue SqlTimeTZ s = f_read getTime s
where
getTime :: ReadP ClockTime
getTime = do
hour <- readS_to_P reads
char ':'
minutes <- readS_to_P reads
char ':'
seconds <- readS_to_P reads
tz <- parseTZ
return (mkClockTime 1970 0 1 hour minutes seconds (tz*3600))
fromSqlValue SqlTime s = f_read getTime s
where
getTime :: ReadP ClockTime
getTime = do
hour <- readS_to_P reads
char ':'
minutes <- readS_to_P reads
char ':'
seconds <- readS_to_P reads
return (mkClockTime 1970 0 1 hour minutes seconds currTZ)
fromSqlValue SqlDate s = f_read getDate s
where
getDate :: ReadP ClockTime
getDate = do
year <- readS_to_P reads
satisfy (=='-')
month <- readS_to_P reads
satisfy (=='-')
day <- readS_to_P reads
return (mkClockTime year month day 0 0 0 currTZ)
fromSqlValue SqlTimeStamp s = f_read getTimeStamp s
where
getTimeStamp :: ReadP ClockTime
getTimeStamp = do
year <- readS_to_P reads
satisfy (=='-')
month <- readS_to_P reads
satisfy (=='-')
day <- readS_to_P reads
skipSpaces
hour <- readS_to_P reads
satisfy (==':')
minutes <- readS_to_P reads
satisfy (==':')
seconds <- readS_to_P reads
tz <- parseTZ
return (mkClockTime year month day hour minutes seconds (tz*3600))
fromSqlValue _ _ = Nothing
toSqlValue ct = '\'' : (shows (ctYear t) .
score .
shows (ctMonth t) .
score .
shows (ctDay t) .
space .
shows (ctHour t) .
colon .
shows (ctMin t) .
colon .
shows (ctSec t)) "'"
where
t = toUTCTime ct
score = showChar '.'
space = showChar ' '
colon = showChar ':'
data Point = Point Double Double deriving (Eq, Show)
data Line = Line Point Point deriving (Eq, Show)
data Path = OpenPath [Point] | ClosedPath [Point] deriving (Eq, Show)
data Box = Box Double Double Double Double deriving (Eq, Show)
data Circle = Circle Point Double deriving (Eq, Show)
data Polygon = Polygon [Point] deriving (Eq, Show)
instance SqlBind Point where
fromSqlValue SqlPoint s = case read s of
(x,y) -> Just (Point x y)
fromSqlValue _ _ = Nothing
toSqlValue (Point x y) = '\'' : shows (x,y) "'"
instance SqlBind Line where
fromSqlValue SqlLSeg s = case read s of
[(x1,y1),(x2,y2)] -> Just (Line (Point x1 y1) (Point x2 y2))
fromSqlValue _ _ = Nothing
toSqlValue (Line (Point x1 y1) (Point x2 y2)) = '\'' : shows [(x1,y1),(x2,y2)] "'"
instance SqlBind Path where
fromSqlValue SqlPath ('(':s) = case read ("["++init s++"]") of -- closed path
ps -> Just (ClosedPath (map (\(x,y) -> Point x y) ps))
fromSqlValue SqlPath s = case read s of -- closed path -- open path
ps -> Just (OpenPath (map (\(x,y) -> Point x y) ps))
fromSqlValue SqlLSeg s = case read s of
[(x1,y1),(x2,y2)] -> Just (OpenPath [(Point x1 y1), (Point x2 y2)])
fromSqlValue SqlPoint s = case read s of
(x,y) -> Just (ClosedPath [Point x y])
fromSqlValue _ _ = Nothing
toSqlValue (OpenPath ps) = '\'' : shows ps "'"
toSqlValue (ClosedPath ps) = "'(" ++ init (tail (show ps)) ++ "')"
instance SqlBind Box where
fromSqlValue SqlBox s = case read ("("++s++")") of
((x1,y1),(x2,y2)) -> Just (Box x1 y1 x2 y2)
fromSqlValue _ _ = Nothing
toSqlValue (Box x1 y1 x2 y2) = '\'' : shows ((x1,y1),(x2,y2)) "'"
instance SqlBind Polygon where
fromSqlValue SqlPolygon s = case read ("["++init (tail s)++"]") of
ps -> Just (Polygon (map (\(x,y) -> Point x y) ps))
fromSqlValue _ _ = Nothing
toSqlValue (Polygon ps) = "'(" ++ init (tail (show ps)) ++ "')"
instance SqlBind Circle where
fromSqlValue SqlCircle s = case read ("("++init (tail s)++")") of
((x,y),r) -> Just (Circle (Point x y) r)
fromSqlValue _ _ = Nothing
toSqlValue (Circle (Point x y) r) = "'<" ++ show (x,y) ++ "," ++ show r ++ "'>"
getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
getFieldValueMB (Statement {pRes=pRes, connection=conn, fields=fieldDefs, countTuples=countTuples, tupleIndex=tupleIndex}) name = do
index <- readIORef tupleIndex
when (index >= countTuples) (throwDyn SqlNoData)
let (sqlType,colNumber) = findFieldInfo name fieldDefs 0
isnull <- pqGetisnull pRes index colNumber
if isnull == 1
then return Nothing
else do
value <- pqGetvalue pRes index colNumber >>= peekCString
case fromSqlValue sqlType value of
Just v -> return (Just v)
Nothing -> throwDyn (SqlBadTypeCast name sqlType)
getFieldValue :: SqlBind a => Statement -> String -> IO a
getFieldValue stmt name = do
mb_v <- getFieldValueMB stmt name
case mb_v of
Nothing -> throwDyn (SqlFetchNull name)
Just a -> return a
getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a
getFieldValue' stmt name def = do
mb_v <- getFieldValueMB stmt name
return (case mb_v of { Nothing -> def; Just a -> a })
getFieldValueType :: Statement -> String -> SqlType
getFieldValueType stmt name = sqlType
where
(sqlType,colNumber) = findFieldInfo name (fields stmt) 1
getFieldsTypes :: Statement -> [(String, SqlType)]
getFieldsTypes = fields
findFieldInfo :: String -> [FieldDef] -> Int -> (SqlType,Int)
findFieldInfo name [] colNumber = error ("Undefined column name \"" ++ name ++ "\"")
findFieldInfo name (fieldDef@(name',sqlType):fields) colNumber
| name == name' = (sqlType,colNumber)
| otherwise = findFieldInfo name fields (colNumber+1)
-----------------------------------------------------------------------------------------
-- helpers
-----------------------------------------------------------------------------------------
forEachRow :: (Statement -> s -> IO s) -> Statement -> s -> IO s
forEachRow f stmt s = do
success <- fetch stmt
if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s
forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()
forEachRow' f stmt = do
success <- fetch stmt
if success then f stmt >> forEachRow' f stmt else closeStatement stmt
collectRows :: (Statement -> IO a) -> Statement -> IO [a]
collectRows f stmt = loop
where
loop = do
success <- fetch stmt
if success
then do
x <- f stmt
xs <- loop
return (x:xs)
else closeStatement stmt >> return []
|
|
From: <kr_...@us...> - 2003-09-06 19:59:10
|
Update of /cvsroot/htoolkit/HSQL
In directory sc8-pr-cvs1:/tmp/cvs-serv11008
Modified Files:
Makefile configure.ac
Log Message:
Support for PostgreSQL. The new implementation has better support for Sql<->Haskell data translation
Index: Makefile
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/Makefile,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Makefile 5 Sep 2003 21:44:09 -0000 1.2
--- Makefile 6 Sep 2003 19:59:06 -0000 1.3
***************
*** 1,64 ****
! include config.mk
!
! ifeq "$(WithODBC)" "YES"
! HS_SRC += ODBC/HSQL.hs
! endif
!
! ifeq "$(WithPostgreSQL)" "YES"
! HS_SRC += PostgreSQL/HSQL.hs
! endif
!
! ifeq "$(WithMySQL)" "YES"
! HS_SRC += MySQL/HSQL.hs
! endif
!
! OBJS = $(patsubst %.hs,%.o, $(HS_SRC))
! HI_SRC = $(patsubst %.hs,%.hi,$(HS_SRC))
!
! ifneq "$(HADDOCK)" ""
! HS_PPS = $(addsuffix .raw-hs, $(basename $(HS_SRC)))
! endif
!
! %.o : %.hs
! mkdir -p $(basename $^)_split
! $(GHC) $< -O -c -fglasgow-exts -split-objs $(CPPFLAGS) -package-name hsql
! $(LD) -r -o $@ $(basename $^)_split/*.o
! %.hs : %.hsc
! $(HSC2HS) $< $(CPPFLAGS)
! %.raw-hs : %.hs
! $(GHC) -Iincludes $(CPPFLAGS) -D__HADDOCK__ -E -cpp $< -o $<.tmp && sed -e 's/^#.*//' <$<.tmp >$@
!
! all: libHSsql.a
!
! libHSsql.a: $(OBJS)
! rm -f libHSsql.a
! for i in $(patsubst %.o,%_split, $(OBJS)); do \
! $(AR) -q libHSsql.a $$i/*.o; \
! done
!
! depend: $(HS_SRC)
! $(GHC) -M $^
!
! clean:
! rm -f $(OBJS)
! rm -f $(HI_SRC)
! rm -f $(HS_PPS)
!
! doc : $(HS_PPS)
! mkdir -p doc
! $(HADDOCK) -h -o doc $(HS_PPS)
!
! install: libHSsql.a $(HI_SRC) doc
! $(INSTALL) libHSsql.a $(prefix)/libHSsql.a
! $(INSTALL) -d $(prefix)/imports/Database
! for i in $(HI_SRC); do \
! $(INSTALL) -d $(prefix)/imports/Database/`dirname $$i`; \
! $(INSTALL) -c $$i $(prefix)/imports/Database/`dirname $$i`; \
! done
! if test -d doc; then \
! $(INSTALL) -d $(prefix)/doc/html/hsql; \
! $(INSTALL) -c doc/* $(prefix)/doc/html/hsql; \
! fi
! $(GHC_PKG) -u -g -i hsql.pkg
!
! ODBC/HSQL.hs : ODBC/HSQLStructs.h
--- 1,66 ----
! include config.mk
!
! ifeq "$(WithODBC)" "YES"
! HS_SRC += ODBC/HSQL.hs
! endif
!
! ifeq "$(WithPostgreSQL)" "YES"
! HS_SRC += PostgreSQL/HSQL.hs
! endif
!
! ifeq "$(WithMySQL)" "YES"
! HS_SRC += MySQL/HSQL.hs
! endif
!
! OBJS = $(patsubst %.hs,%.o, $(HS_SRC))
! HI_SRC = $(patsubst %.hs,%.hi,$(HS_SRC))
!
! ifneq "$(HADDOCK)" ""
! HS_PPS = $(addsuffix .raw-hs, $(basename $(HS_SRC)))
! HADDOCK = echo
! endif
!
! %.o : %.hs
! mkdir -p $(basename $^)_split
! rm -f $(basename $^)_split/*
! $(GHC) $< -O -c -fglasgow-exts -split-objs $(CPPFLAGS) -package-name hsql
! $(LD) -r -o $@ $(basename $^)_split/*.o
! %.hs : %.hsc
! $(HSC2HS) $< $(CPPFLAGS)
! %.raw-hs : %.hs
! $(GHC) -Iincludes $(CPPFLAGS) -D__HADDOCK__ -E -cpp $< -o $<.tmp && sed -e 's/^#.*//' <$<.tmp >$@
!
! all: libHSsql.a
!
! libHSsql.a: $(OBJS)
! rm -f libHSsql.a
! for i in $(patsubst %.o,%_split, $(OBJS)); do \
! $(AR) -q libHSsql.a $$i/*.o; \
! done
!
! depend: $(HS_SRC)
! $(GHC) -M $^
!
! clean:
! rm -f $(OBJS)
! rm -f $(HI_SRC)
! rm -f $(HS_PPS)
!
! doc : $(HS_PPS)
! mkdir -p doc
! $(HADDOCK) -h -o doc $(HS_PPS)
!
! install: libHSsql.a $(HI_SRC) doc
! $(INSTALL) libHSsql.a $(prefix)/libHSsql.a
! $(INSTALL) -d $(prefix)/imports/Database
! for i in $(HI_SRC); do \
! $(INSTALL) -d $(prefix)/imports/Database/`dirname $$i`; \
! $(INSTALL) -c $$i $(prefix)/imports/Database/`dirname $$i`; \
! done
! $(GHC_PKG) -u -g -i hsql.pkg
! if test -f doc/index.html; then \
! $(INSTALL) -d $(prefix)/doc/html/hsql; \
! $(INSTALL) -c doc/* $(prefix)/doc/html/hsql; \
! fi
!
! ODBC/HSQL.hs : ODBC/HSQLStructs.h
Index: configure.ac
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/configure.ac,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** configure.ac 5 Sep 2003 21:44:10 -0000 1.2
--- configure.ac 6 Sep 2003 19:59:06 -0000 1.3
***************
*** 1,234 ****
! AC_INIT([HSQL],[1.0],[hto...@li...],[hsql])
!
! AC_CONFIG_FILES([config.mk:config.mk.in hsql.pkg:hsql.pkg.in])
!
! AC_CANONICAL_SYSTEM
!
! dnl ***********************************************
! dnl Enable/Disable ODBC binding
! dnl ***********************************************
! AC_ARG_ENABLE(odbc,
! [ --enable-odbc
! Build an ODBC binding for Haskell.
! ],
! [WithODBC=YES],
! [WithODBC=NO]
! )
! AC_SUBST(WithODBC)
!
! dnl ***********************************************
! dnl Enable/Disable PostgreSQL binding
! dnl ***********************************************
! AC_ARG_ENABLE(postgres,
! [ --enable-postgres
! Build a PostgreSQL binding for Haskell.
! ],
! [WithPostgreSQL=YES],
! [WithPostgreSQL=NO]
! )
! AC_SUBST(WithPostgreSQL)
!
! dnl ***********************************************
! dnl Enable/Disable MySQL binding
! dnl ***********************************************
! AC_ARG_ENABLE(mysql,
! [ --enable-mysql
! Build a MySQL binding for Haskell.
! ],
! [WithMySQL=YES],
! [WithMySQL=NO]
! )
! AC_SUBST(WithMySQL)
!
! dnl ***********************************************
! dnl GHC
! dnl ***********************************************
! AC_ARG_WITH(ghc,
! [ --with-ghc=<ghc command>
! Use a different command instead of 'ghc' for the Haskell compiler.
! ],
! [GHC="$withval"],
! [AC_PATH_PROG(GHC,ghc)]
! )
!
! if test "$GHC" = "" || test ! -f $GHC; then
! AC_MSG_ERROR([GHC is required to build the package])
! fi
!
! AC_SUBST(GHC)
!
! if test "$prefix" = "NONE"; then
! prefix=`$GHC --print-libdir`
! fi
!
! dnl ***********************************************
! dnl hsc2hs
! dnl ***********************************************
! AC_ARG_WITH(hsc2hs,
! [ --with-hsc2hs=<hsc2hs command>
! Use a different command instead of 'hsc2hs'
! ],
! [HSC2HS="$withval"],
! [AC_PATH_PROG(HSC2HS,hsc2hs)]
! )
!
! if test "$HSC2HS" = "" || test ! -f $HSC2HS; then
! AC_MSG_ERROR([HSC2HS is required to build the package])
! fi
!
! AC_SUBST(HSC2HS)
!
! dnl ***********************************************
! dnl ghc-pkg
! dnl ***********************************************
! AC_ARG_WITH(ghc-pkg,
! [ --with-ghc-pkg=<ghc-pkg command>
! Use a different command instead of 'ghc-pkg'
! ],
! [GHC_PKG="$withval"],
! [AC_PATH_PROG(GHC_PKG,ghc-pkg)]
! )
!
! if test "$GHC_PKG" = "" || test ! -f $GHC_PKG; then
! AC_MSG_ERROR([ghc-pkg is required to build the package])
! fi
!
! AC_SUBST(GHC_PKG)
!
! dnl ***********************************************
! dnl HADDOCK
! dnl ***********************************************
! AC_ARG_WITH(haddock,
! [ --with-haddock=<haddock command>
! Use a different command instead of 'haddock' for the documentation builder.
! ],
! [HADDOCK="$withval"],
! [AC_PATH_PROG(HADDOCK,haddock)]
! )
!
! if test "$HADDOCK" = "" || test ! -f $HADDOCK; then
! echo HADDOCK is required to build the documentations
! fi
!
! AC_SUBST(HADDOCK)
!
! dnl ***********************************************
! dnl other progs
! dnl ***********************************************
!
AC_PROG_CC
! AC_PROG_CPP
! AC_PROG_INSTALL
!
! AC_PATH_PROG(AR,ar)
! AC_SUBST(AR)
!
! AC_PATH_PROG(LD,ld)
! AC_SUBST(LD)
!
! dnl ***********************************************
! dnl check for headers and libraries for ODBC
! dnl ***********************************************
!
! if test $WithODBC = YES; then
! case $ac_cv_target_alias in
! i[[3456]]86-*-cygwin*|i[[3456]]86-*-mingw32*)
! AC_COMPILE_IFELSE(
! [
! #include <windows.h>
! #include <sqlext.h>
!
! int main()
! {
! SQLAllocEnv (NULL);
! return 0;
! }
! ],
! [LIBS="${LIBS} -lodbc32"],
! AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
! ;;
! *) AC_CHECK_HEADER(sqlext.h,,AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
! AC_CHECK_LIB(odbc,SQLAllocEnv,,AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
! ;;
! esac
!
! CPPFLAGS="$CPPFLAGS -IODBC"
! fi
!
! dnl ***********************************************
! dnl check for headers and libraries for PostgreSQL
! dnl ***********************************************
!
! if test $WithPostgreSQL = YES; then
! AC_PATH_PROG(PG_CONFIG, pg_config)
!
! if test "$PG_CONFIG" = "" || test ! -f $PG_CONFIG; then
! AC_MSG_ERROR([pg_config is required to build PostgreSQL binding])
! fi
!
! case $ac_cv_target_alias in
! i[[3456]]86-*-cygwin*|i[[3456]]86-*-mingw32*)
! LDFLAGS="$LDFLAGS -L$(cygpath -m `$PG_CONFIG --libdir`)"
! CPPFLAGS="$CPPFLAGS -I$(cygpath -m /usr/include) -I$(cygpath -m `$PG_CONFIG --includedir`)"
! ;;
! *) LDFLAGS="$LDFLAGS -L`$PG_CONFIG --libdir`"
! CPPFLAGS="$CPPFLAGS -I`$PG_CONFIG --includedir`"
! ;;
! esac
!
! AC_CHECK_HEADER(libpq-fe.h,,AC_MSG_ERROR([libpq-fe.h header not found]))
! AC_CHECK_LIB(pq,PQsetdbLogin,,AC_MSG_ERROR([libpq.a library not found]))
! fi
!
! dnl ***********************************************
! dnl check for headers and libraries for MySQL
! dnl ***********************************************
!
! if test $WithMySQL = YES; then
! AC_PATH_PROG(MYSQL_CONFIG, mysql_config)
!
! if test "$MYSQL_CONFIG" = "" || test ! -f $MYSQL_CONFIG; then
! AC_MSG_ERROR([mysql_config is required to build PostgreSQL binding])
! fi
!
! LDFLAGS="$LDFLAGS `$MYSQL_CONFIG --libs`"
! CPPFLAGS="$CPPFLAGS `$MYSQL_CONFIG --cflags`"
!
! AC_CHECK_HEADER(mysql/mysql.h,, AC_MSG_ERROR([mysql.h header not found]))
!
! fi
!
! dnl ***********************************************
! dnl subst
! dnl ***********************************************
!
! LL="$LIBS $LDFLAGS"
!
! if test "x$prefix" != xNONE; then
! LIB_DIRS='"'${prefix}'"'
! else
! LIB_DIRS='"'${ac_default_prefix}'"'
! fi
!
! for lib_opt in ${LL}
! do
! case $lib_opt in
! -l*)
! if test x$DEP_LIBS = x; then
! DEP_LIBS='"'`echo ${lib_opt} | sed s,-l,,`'"'
! else
! DEP_LIBS=$DEP_LIBS,'"'`echo ${lib_opt} | sed s,-l,,`'"'
! fi;;
! -L*)
! LIB_DIRS=$LIB_DIRS,'"'`echo ${lib_opt} | sed s,-L,, | sed s,"'",, | sed s,"'",,`'"'
! esac
! done
!
! AC_SUBST(CPPFLAGS)
! AC_SUBST(DEP_LIBS)
! AC_SUBST(LIB_DIRS)
! AC_SUBST(prefix)
! AC_SUBST(exec_prefix)
! AC_SUBST(libdir)
!
! AC_OUTPUT
--- 1,234 ----
! AC_INIT([HSQL],[1.0],[hto...@li...],[hsql])
!
! AC_CONFIG_FILES([config.mk:config.mk.in hsql.pkg:hsql.pkg.in])
!
! AC_CANONICAL_SYSTEM
!
! dnl ***********************************************
! dnl Enable/Disable ODBC binding
! dnl ***********************************************
! AC_ARG_ENABLE(odbc,
! [ --enable-odbc
! Build an ODBC binding for Haskell.
! ],
! [WithODBC=YES],
! [WithODBC=NO]
! )
! AC_SUBST(WithODBC)
!
! dnl ***********************************************
! dnl Enable/Disable PostgreSQL binding
! dnl ***********************************************
! AC_ARG_ENABLE(postgres,
! [ --enable-postgres
! Build a PostgreSQL binding for Haskell.
! ],
! [WithPostgreSQL=YES],
! [WithPostgreSQL=NO]
! )
! AC_SUBST(WithPostgreSQL)
!
! dnl ***********************************************
! dnl Enable/Disable MySQL binding
! dnl ***********************************************
! AC_ARG_ENABLE(mysql,
! [ --enable-mysql
! Build a MySQL binding for Haskell.
! ],
! [WithMySQL=YES],
! [WithMySQL=NO]
! )
! AC_SUBST(WithMySQL)
!
! dnl ***********************************************
! dnl GHC
! dnl ***********************************************
! AC_ARG_WITH(ghc,
! [ --with-ghc=<ghc command>
! Use a different command instead of 'ghc' for the Haskell compiler.
! ],
! [GHC="$withval"],
! [AC_PATH_PROG(GHC,ghc)]
! )
!
! if test "$GHC" = "" || test ! -f $GHC; then
! AC_MSG_ERROR([GHC is required to build the package])
! fi
!
! AC_SUBST(GHC)
!
! if test "$prefix" = "NONE"; then
! prefix=`$GHC --print-libdir`
! fi
!
! dnl ***********************************************
! dnl hsc2hs
! dnl ***********************************************
! AC_ARG_WITH(hsc2hs,
! [ --with-hsc2hs=<hsc2hs command>
! Use a different command instead of 'hsc2hs'
! ],
! [HSC2HS="$withval"],
! [AC_PATH_PROG(HSC2HS,hsc2hs)]
! )
!
! if test "$HSC2HS" = "" || test ! -f $HSC2HS; then
! AC_MSG_ERROR([HSC2HS is required to build the package])
! fi
!
! AC_SUBST(HSC2HS)
!
! dnl ***********************************************
! dnl ghc-pkg
! dnl ***********************************************
! AC_ARG_WITH(ghc-pkg,
! [ --with-ghc-pkg=<ghc-pkg command>
! Use a different command instead of 'ghc-pkg'
! ],
! [GHC_PKG="$withval"],
! [AC_PATH_PROG(GHC_PKG,ghc-pkg)]
! )
!
! if test "$GHC_PKG" = "" || test ! -f $GHC_PKG; then
! AC_MSG_ERROR([ghc-pkg is required to build the package])
! fi
!
! AC_SUBST(GHC_PKG)
!
! dnl ***********************************************
! dnl HADDOCK
! dnl ***********************************************
! AC_ARG_WITH(haddock,
! [ --with-haddock=<haddock command>
! Use a different command instead of 'haddock' for the documentation builder.
! ],
! [HADDOCK="$withval"],
! [AC_PATH_PROG(HADDOCK,haddock)]
! )
!
! if test "$HADDOCK" = "" || test ! -f $HADDOCK; then
! echo HADDOCK is required to build the documentations
! fi
!
! AC_SUBST(HADDOCK)
!
! dnl ***********************************************
! dnl other progs
! dnl ***********************************************
!
AC_PROG_CC
! AC_PROG_CPP
! AC_PROG_INSTALL
!
! AC_PATH_PROG(AR,ar)
! AC_SUBST(AR)
!
! AC_PATH_PROG(LD,ld)
! AC_SUBST(LD)
!
! dnl ***********************************************
! dnl check for headers and libraries for ODBC
! dnl ***********************************************
!
! if test $WithODBC = YES; then
! case $ac_cv_target_alias in
! i[[3456]]86-*-cygwin*|i[[3456]]86-*-mingw32*)
! AC_COMPILE_IFELSE(
! [
! #include <windows.h>
! #include <sqlext.h>
!
! int main()
! {
! SQLAllocEnv (NULL);
! return 0;
! }
! ],
! [LIBS="${LIBS} -lodbc32"],
! AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
! ;;
! *) AC_CHECK_HEADER(sqlext.h,,AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
! AC_CHECK_LIB(odbc,SQLAllocEnv,,AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
! ;;
! esac
!
! CPPFLAGS="$CPPFLAGS -IODBC"
! fi
!
! dnl ***********************************************
! dnl check for headers and libraries for PostgreSQL
! dnl ***********************************************
!
! if test $WithPostgreSQL = YES; then
! AC_PATH_PROG(PG_CONFIG, pg_config)
!
! if test "$PG_CONFIG" = "" || test ! -f $PG_CONFIG; then
! AC_MSG_ERROR([pg_config is required to build PostgreSQL binding])
! fi
!
! case $ac_cv_target_alias in
! i[[3456]]86-*-cygwin*|i[[3456]]86-*-mingw32*)
! LDFLAGS="$LDFLAGS -L$(cygpath -m `$PG_CONFIG --libdir`)"
! CPPFLAGS="$CPPFLAGS -I$(cygpath -m /usr/include) -I$(cygpath -m `$PG_CONFIG --includedir`)"
! ;;
! *) LDFLAGS="$LDFLAGS -L`$PG_CONFIG --libdir`"
! CPPFLAGS="$CPPFLAGS -I`$PG_CONFIG --includedir` -I`$PG_CONFIG --includedir`/server"
! ;;
! esac
!
! AC_CHECK_HEADER(libpq-fe.h,,AC_MSG_ERROR([libpq-fe.h header not found]))
! AC_CHECK_LIB(pq,PQsetdbLogin,,AC_MSG_ERROR([libpq.a library not found]))
! fi
!
! dnl ***********************************************
! dnl check for headers and libraries for MySQL
! dnl ***********************************************
!
! if test $WithMySQL = YES; then
! AC_PATH_PROG(MYSQL_CONFIG, mysql_config)
!
! if test "$MYSQL_CONFIG" = "" || test ! -f $MYSQL_CONFIG; then
! AC_MSG_ERROR([mysql_config is required to build PostgreSQL binding])
! fi
!
! LDFLAGS="$LDFLAGS `$MYSQL_CONFIG --libs`"
! CPPFLAGS="$CPPFLAGS `$MYSQL_CONFIG --cflags`"
!
! AC_CHECK_HEADER(mysql/mysql.h,, AC_MSG_ERROR([mysql.h header not found]))
!
! fi
!
! dnl ***********************************************
! dnl subst
! dnl ***********************************************
!
! LL="$LIBS $LDFLAGS"
!
! if test "x$prefix" != xNONE; then
! LIB_DIRS='"'${prefix}'"'
! else
! LIB_DIRS='"'${ac_default_prefix}'"'
! fi
!
! for lib_opt in ${LL}
! do
! case $lib_opt in
! -l*)
! if test x$DEP_LIBS = x; then
! DEP_LIBS='"'`echo ${lib_opt} | sed s,-l,,`'"'
! else
! DEP_LIBS=$DEP_LIBS,'"'`echo ${lib_opt} | sed s,-l,,`'"'
! fi;;
! -L*)
! LIB_DIRS=$LIB_DIRS,'"'`echo ${lib_opt} | sed s,-L,, | sed s,"'",, | sed s,"'",,`'"'
! esac
! done
!
! AC_SUBST(CPPFLAGS)
! AC_SUBST(DEP_LIBS)
! AC_SUBST(LIB_DIRS)
! AC_SUBST(prefix)
! AC_SUBST(exec_prefix)
! AC_SUBST(libdir)
!
! AC_OUTPUT
|
|
From: <kr_...@us...> - 2003-09-05 22:54:41
|
Update of /cvsroot/htoolkit/HSQL/PostgreSQL In directory sc8-pr-cvs1:/tmp/cvs-serv21491/PostgreSQL Log Message: Directory /cvsroot/htoolkit/HSQL/PostgreSQL added to the repository |
|
From: <kr_...@us...> - 2003-09-05 21:44:17
|
Update of /cvsroot/htoolkit/HSQL
In directory sc8-pr-cvs1:/tmp/cvs-serv9791
Modified Files:
Makefile configure.ac hsql.pkg.in
Log Message:
Full redesign of build system
Index: Makefile
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/Makefile,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Makefile 5 Sep 2003 11:37:55 -0000 1.1
--- Makefile 5 Sep 2003 21:44:09 -0000 1.2
***************
*** 2,34 ****
ifeq "$(WithODBC)" "YES"
! HS_SRC += src/ODBC/HSQL.hs
! CPPFLAGS += -Isrc/ODBC
endif
ifeq "$(WithPostgreSQL)" "YES"
! HS_SRC += src/PostgreSQL/HSQL.hs
endif
ifeq "$(WithMySQL)" "YES"
! HS_SRC += src/MySQL/HSQL.hs
endif
OBJS = $(patsubst %.hs,%.o, $(HS_SRC))
HI_SRC = $(patsubst %.hs,%.hi,$(HS_SRC))
HS_PPS = $(addsuffix .raw-hs, $(basename $(HS_SRC)))
%.o : %.hs
! $(GHC) $< $($*_HC_OPTS) -O -c -fglasgow-exts -Iincludes $(CPPFLAGS) -package-name HToolkit
%.hs : %.hsc
! $(HSC2HS) $< -Iincludes $(CPPFLAGS)
! %.hi : %.o
! @
%.raw-hs : %.hs
$(GHC) -Iincludes $(CPPFLAGS) -D__HADDOCK__ -E -cpp $< -o $<.tmp && sed -e 's/^#.*//' <$<.tmp >$@
! all: $(OBJS)
! echo $(HS_SRC)
rm -f libHSsql.a
! $(AR) -q libHSsql.a $^
depend: $(HS_SRC)
--- 2,39 ----
ifeq "$(WithODBC)" "YES"
! HS_SRC += ODBC/HSQL.hs
endif
ifeq "$(WithPostgreSQL)" "YES"
! HS_SRC += PostgreSQL/HSQL.hs
endif
ifeq "$(WithMySQL)" "YES"
! HS_SRC += MySQL/HSQL.hs
endif
OBJS = $(patsubst %.hs,%.o, $(HS_SRC))
HI_SRC = $(patsubst %.hs,%.hi,$(HS_SRC))
+
+ ifneq "$(HADDOCK)" ""
HS_PPS = $(addsuffix .raw-hs, $(basename $(HS_SRC)))
+ endif
%.o : %.hs
! mkdir -p $(basename $^)_split
! $(GHC) $< -O -c -fglasgow-exts -split-objs $(CPPFLAGS) -package-name hsql
! $(LD) -r -o $@ $(basename $^)_split/*.o
%.hs : %.hsc
! $(HSC2HS) $< $(CPPFLAGS)
%.raw-hs : %.hs
$(GHC) -Iincludes $(CPPFLAGS) -D__HADDOCK__ -E -cpp $< -o $<.tmp && sed -e 's/^#.*//' <$<.tmp >$@
! all: libHSsql.a
!
! libHSsql.a: $(OBJS)
rm -f libHSsql.a
! for i in $(patsubst %.o,%_split, $(OBJS)); do \
! $(AR) -q libHSsql.a $$i/*.o; \
! done
depend: $(HS_SRC)
***************
*** 44,53 ****
$(HADDOCK) -h -o doc $(HS_PPS)
! install: libHSsql.a $(HI_SRC)
$(INSTALL) libHSsql.a $(prefix)/libHSsql.a
! $(INSTALL) -d $(prefix)/imports/hsql
for i in $(HI_SRC); do \
! $(INSTALL) -d $(prefix)/imports/hsql/`dirname $$i`; \
! $(INSTALL) -c $$i $(prefix)/imports/hsql/`dirname $$i`; \
done
! $(GHC_PKG) -u -g -i hsql.pkg.in
--- 49,64 ----
$(HADDOCK) -h -o doc $(HS_PPS)
! install: libHSsql.a $(HI_SRC) doc
$(INSTALL) libHSsql.a $(prefix)/libHSsql.a
! $(INSTALL) -d $(prefix)/imports/Database
for i in $(HI_SRC); do \
! $(INSTALL) -d $(prefix)/imports/Database/`dirname $$i`; \
! $(INSTALL) -c $$i $(prefix)/imports/Database/`dirname $$i`; \
done
! if test -d doc; then \
! $(INSTALL) -d $(prefix)/doc/html/hsql; \
! $(INSTALL) -c doc/* $(prefix)/doc/html/hsql; \
! fi
! $(GHC_PKG) -u -g -i hsql.pkg
!
! ODBC/HSQL.hs : ODBC/HSQLStructs.h
Index: configure.ac
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/configure.ac,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** configure.ac 5 Sep 2003 11:37:55 -0000 1.1
--- configure.ac 5 Sep 2003 21:44:10 -0000 1.2
***************
*** 1,3 ****
! AC_INIT([HSQL],[1.0],[ka2...@ya...],[hsql])
AC_CONFIG_FILES([config.mk:config.mk.in hsql.pkg:hsql.pkg.in])
--- 1,3 ----
! AC_INIT([HSQL],[1.0],[hto...@li...],[hsql])
AC_CONFIG_FILES([config.mk:config.mk.in hsql.pkg:hsql.pkg.in])
***************
*** 58,61 ****
--- 58,65 ----
AC_SUBST(GHC)
+ if test "$prefix" = "NONE"; then
+ prefix=`$GHC --print-libdir`
+ fi
+
dnl ***********************************************
dnl hsc2hs
***************
*** 114,117 ****
--- 118,122 ----
AC_PROG_CC
+ AC_PROG_CPP
AC_PROG_INSTALL
***************
*** 127,152 ****
if test $WithODBC = YES; then
! case $ac_cv_target_alias in
! i[[3456]]86-*-cygwin*|i[[3456]]86-*-mingw32*)
! AC_COMPILE_IFELSE(
! [
! #include <windows.h>
! #include <sqlext.h>
!
! int main()
! {
! SQLAllocEnv (NULL);
! return 0;
! }
! ],
! [LIBS="${LIBS} -lodbc32"],
! AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
! ;;
! *) AC_CHECK_HEADER(sqlext.h,,AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
! AC_CHECK_LIB(odbc,SQLAllocEnv,,AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
! ;;
! esac
!
fi
--- 132,157 ----
if test $WithODBC = YES; then
+ case $ac_cv_target_alias in
+ i[[3456]]86-*-cygwin*|i[[3456]]86-*-mingw32*)
+ AC_COMPILE_IFELSE(
+ [
+ #include <windows.h>
+ #include <sqlext.h>
+
+ int main()
+ {
+ SQLAllocEnv (NULL);
+ return 0;
+ }
+ ],
+ [LIBS="${LIBS} -lodbc32"],
+ AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
+ ;;
+ *) AC_CHECK_HEADER(sqlext.h,,AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
+ AC_CHECK_LIB(odbc,SQLAllocEnv,,AC_MSG_ERROR([sqlext.h and libodbc required to build ODBC building.]))
+ ;;
+ esac
! CPPFLAGS="$CPPFLAGS -IODBC"
fi
***************
*** 156,174 ****
if test $WithPostgreSQL = YES; then
! AC_PATH_PROG(PG_CONFIG, pg_config)
!
! if test x$PG_CONFIG = x || test ! -f $PG_CONFIG; then
! AC_MSG_ERROR([pg_config is required to build PostgreSQL binding])
! fi
!
! LDFLAGS="$LDFLAGS -L`$PG_CONFIG --libdir`"
! CPPFLAGS="$CPPFLAGS -I`$PG_CONFIG --includedir`"
! AC_CHECK_HEADER(libpq-fe.h,[
! AC_CHECK_HEADER(postgres.h,, AC_MSG_ERROR([catalog/postgres.h header not found]))
! ], AC_MSG_ERROR([libpq-fe.h header not found]))
! AC_CHECK_LIB(pq,PQsetdbLogin,,AC_MSG_ERROR([libpq.a library not found]))
fi
--- 161,182 ----
if test $WithPostgreSQL = YES; then
! AC_PATH_PROG(PG_CONFIG, pg_config)
! if test "$PG_CONFIG" = "" || test ! -f $PG_CONFIG; then
! AC_MSG_ERROR([pg_config is required to build PostgreSQL binding])
! fi
! case $ac_cv_target_alias in
! i[[3456]]86-*-cygwin*|i[[3456]]86-*-mingw32*)
! LDFLAGS="$LDFLAGS -L$(cygpath -m `$PG_CONFIG --libdir`)"
! CPPFLAGS="$CPPFLAGS -I$(cygpath -m /usr/include) -I$(cygpath -m `$PG_CONFIG --includedir`)"
! ;;
! *) LDFLAGS="$LDFLAGS -L`$PG_CONFIG --libdir`"
! CPPFLAGS="$CPPFLAGS -I`$PG_CONFIG --includedir`"
! ;;
! esac
+ AC_CHECK_HEADER(libpq-fe.h,,AC_MSG_ERROR([libpq-fe.h header not found]))
+ AC_CHECK_LIB(pq,PQsetdbLogin,,AC_MSG_ERROR([libpq.a library not found]))
fi
***************
*** 180,184 ****
AC_PATH_PROG(MYSQL_CONFIG, mysql_config)
! if test x$MYSQL_CONFIG = x || test ! -f $MYSQL_CONFIG; then
AC_MSG_ERROR([mysql_config is required to build PostgreSQL binding])
fi
--- 188,192 ----
AC_PATH_PROG(MYSQL_CONFIG, mysql_config)
! if test "$MYSQL_CONFIG" = "" || test ! -f $MYSQL_CONFIG; then
AC_MSG_ERROR([mysql_config is required to build PostgreSQL binding])
fi
Index: hsql.pkg.in
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/hsql.pkg.in,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** hsql.pkg.in 5 Sep 2003 11:37:55 -0000 1.1
--- hsql.pkg.in 5 Sep 2003 21:44:10 -0000 1.2
***************
*** 2,6 ****
{name = "hsql",
auto=True,
! import_dirs = ["@prefix@/imports/hsql"],
source_dirs = [],
library_dirs = [@LIB_DIRS@],
--- 2,6 ----
{name = "hsql",
auto=True,
! import_dirs = ["@prefix@/imports"],
source_dirs = [],
library_dirs = [@LIB_DIRS@],
|
|
From: <kr_...@us...> - 2003-09-05 21:44:16
|
Update of /cvsroot/htoolkit/HSQL/ODBC
In directory sc8-pr-cvs1:/tmp/cvs-serv9791/ODBC
Added Files:
HSQL.hsc HSQLStructs.h
Log Message:
Full redesign of build system
--- NEW FILE: HSQL.hsc ---
-----------------------------------------------------------------------------------------
{-| Module : Database.ODBC.HSQL
Copyright : (c) Krasimir Angelov 2003
License : BSD-style
Maintainer : ka2...@ya...
Stability : provisional
Portability : portable
The module provides interface to ODBC
-}
-----------------------------------------------------------------------------------------
module Database.ODBC.HSQL
( SqlBind(..), SqlError(..), SqlType(..), Connection, Statement
, catchSql -- :: IO a -> (SqlError -> IO a) -> IO a
, handleSql -- :: (SqlError -> IO a) -> IO a -> IO a
, sqlExceptions -- :: Exception -> Maybe SqlError
, connect -- :: String -> String -> String -> IO Connection
, disconnect -- :: Connection -> IO ()
, execute -- :: Connection -> String -> IO ()
, query -- :: Connection -> String -> IO Statement
, closeStatement -- :: Statement -> IO ()
, fetch -- :: Statement -> IO Bool
, inTransaction -- :: Connection -> (Connection -> IO a) -> IO a
, getFieldValueMB -- :: SqlBind a => Statement -> String -> IO (Maybe a)
, getFieldValue -- :: SqlBind a => Statement -> String -> IO a
, getFieldValue' -- :: SqlBind a => Statement -> String -> a -> IO a
, getFieldValueType -- :: Statement -> String -> (SqlType, Bool)
, getFieldsTypes -- :: Statement -> [(String, SqlType, Bool)]
, forEachRow -- :: (Statement -> s -> IO s) -> Statement -> s -> IO s
, forEachRow' -- :: (Statement -> IO ()) -> Statement -> IO ()
, collectRows -- :: (Statement -> IO s) -> Statement -> IO [s]
) where
import Data.Word(Word32, Word16)
import Data.Int(Int32, Int16)
import Data.IORef
import Data.Dynamic
import Foreign
import Foreign.C
import qualified Foreign.Concurrent as C
import Control.Monad(when,unless)
import Control.Exception (throwDyn, catchDyn, dynExceptions, Exception(..))
import System.IO.Unsafe
import System.Time
#include <time.h>
#include <HSQLStructs.h>
type SQLHANDLE = Ptr ()
type HENV = SQLHANDLE
type HDBC = SQLHANDLE
type HSTMT = SQLHANDLE
type HENVRef = ForeignPtr ()
type SQLSMALLINT = #type SQLSMALLINT
type SQLUSMALLINT = #type SQLUSMALLINT
type SQLINTEGER = #type SQLINTEGER
type SQLUINTEGER = #type SQLUINTEGER
type SQLRETURN = SQLSMALLINT
type SQLLEN = SQLINTEGER
type SQLULEN = SQLINTEGER
foreign import stdcall "sqlext.h SQLAllocEnv" sqlAllocEnv :: Ptr HENV -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLFreeEnv" sqlFreeEnv :: HENV -> IO ()
foreign import stdcall "sqlext.h SQLAllocConnect" sqlAllocConnect :: HENV -> Ptr HDBC -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLFreeConnect" sqlFreeConnect:: HDBC -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLConnect" sqlConnect :: HDBC -> CString -> Int -> CString -> Int -> CString -> Int -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLDisconnect" sqlDisconnect :: HDBC -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLAllocStmt" sqlAllocStmt :: HDBC -> Ptr HSTMT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLFreeStmt" sqlFreeStmt :: HSTMT -> SQLUSMALLINT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLNumResultCols" sqlNumResultCols :: HSTMT -> Ptr SQLUSMALLINT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLDescribeCol" sqlDescribeCol :: HSTMT -> SQLUSMALLINT -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLULEN -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLBindCol" sqlBindCol :: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr a -> SQLLEN -> Ptr SQLINTEGER -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLFetch" sqlFetch :: HSTMT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLGetDiagRec" sqlGetDiagRec :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> CString -> Ptr SQLINTEGER -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLExecDirect" sqlExecDirect :: HSTMT -> CString -> Int -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLSetConnectOption" sqlSetConnectOption :: HDBC -> SQLUSMALLINT -> SQLULEN -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLTransact" sqlTransact :: HENV -> HDBC -> SQLUSMALLINT -> IO SQLRETURN
foreign import stdcall "sqlext.h SQLGetData" sqlGetData :: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr () -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN
-- | A 'Connection' type represents a connection to a data source, through which you can operate on the data source.
-- A data source is a specific instance of data hosted by some database management system.
data Connection
= Connection
{ hDBC :: HDBC
, environment :: HENVRef
}
data Statement
= Statement
{ hSTMT :: !HSTMT
, connection :: !Connection
, fields :: ![FieldDef]
, fetchBuffer :: !(Ptr ())
, fetchBufferSize :: !SQLINTEGER
}
type FieldDef = (String, SqlType, Bool)
data SqlType
= SqlChar Int
| SqlVarChar Int
| SqlLongVarChar Int
| SqlDecimal Int Int
| SqlNumeric Int Int
| SqlSmallInt
| SqlInteger
| SqlReal
| SqlDouble
| SqlBit
| SqlTinyInt
| SqlBigInt
| SqlBinary Int
| SqlVarBinary Int
| SqlLongVarBinary Int
| SqlDate
| SqlTime
| SqlTimeStamp
deriving (Eq, Show)
data SqlError
= SqlError
{ seState :: String
, seNativeError :: Int
, seErrorMsg :: String
}
| SqlNoData
| SqlInvalidHandle
| SqlStillExecuting
| SqlNeedData
deriving Show
-----------------------------------------------------------------------------------------
-- routines for handling exceptions
-----------------------------------------------------------------------------------------
{-# NOINLINE sqlErrorTy #-}
sqlErrorTy = mkAppTy (mkTyCon "SqlError") []
instance Typeable SqlError where
typeOf x = sqlErrorTy
catchSql :: IO a -> (SqlError -> IO a) -> IO a
catchSql = catchDyn
handleSql :: (SqlError -> IO a) -> IO a -> IO a
handleSql h f = catchDyn f h
sqlExceptions :: Exception -> Maybe SqlError
sqlExceptions e = dynExceptions e >>= fromDynamic
sqlSuccess :: SQLRETURN -> Bool
sqlSuccess res =
(res == (#const SQL_SUCCESS)) || (res == (#const SQL_SUCCESS_WITH_INFO)) || (res == (#const SQL_NO_DATA))
handleSqlResult :: SQLSMALLINT -> SQLHANDLE -> SQLRETURN -> IO ()
handleSqlResult handleType handle res
| sqlSuccess res = return ()
| res == (#const SQL_INVALID_HANDLE) = throwDyn SqlInvalidHandle
| res == (#const SQL_STILL_EXECUTING) = throwDyn SqlStillExecuting
| res == (#const SQL_NEED_DATA) = throwDyn SqlNeedData
| res == (#const SQL_ERROR) = do
pState <- mallocBytes 256
pNative <- malloc
pMsg <- mallocBytes 256
pTextLen <- malloc
sqlGetDiagRec handleType handle 1 pState pNative pMsg 256 pTextLen
state <- peekCString pState
free pState
native <- peek pNative
free pNative
msg <- peekCString pMsg
free pMsg
free pTextLen
throwDyn (SqlError {seState=state, seNativeError=fromIntegral native, seErrorMsg=msg})
| otherwise = error (show res)
-----------------------------------------------------------------------------------------
-- keeper of HENV
-----------------------------------------------------------------------------------------
{-# NOINLINE myEnvironment #-}
myEnvironment :: HENVRef
myEnvironment = unsafePerformIO $ do
(phEnv :: Ptr HENV) <- malloc
res <- sqlAllocEnv phEnv
hEnv <- peek phEnv
free phEnv
handleSqlResult 0 nullPtr res
C.newForeignPtr hEnv (sqlFreeEnv hEnv)
-----------------------------------------------------------------------------------------
-- Connect/Disconnect
-----------------------------------------------------------------------------------------
connect :: String -> String -> String -> IO Connection
connect server user authentication = withForeignPtr myEnvironment $ \hEnv -> do
(phDBC :: Ptr HDBC) <- malloc
res <- sqlAllocConnect hEnv phDBC
hDBC <- peek phDBC
free phDBC
handleSqlResult (#const SQL_HANDLE_ENV) hEnv res
pServer <- newCString server
pUser <- newCString user
pAuthentication <- newCString authentication
res <- sqlConnect hDBC pServer (length server) pUser (length user) pAuthentication (length authentication)
free pServer
free pUser
free pAuthentication
handleSqlResult (#const SQL_HANDLE_ENV) hEnv res
return (Connection {hDBC=hDBC, environment=myEnvironment})
disconnect :: Connection -> IO ()
disconnect (Connection {hDBC=hDBC}) = do
sqlDisconnect hDBC >>= handleSqlResult (#const SQL_HANDLE_DBC) hDBC
sqlFreeConnect hDBC >>= handleSqlResult (#const SQL_HANDLE_DBC) hDBC
return ()
-----------------------------------------------------------------------------------------
-- queries
-----------------------------------------------------------------------------------------
execute :: Connection -> String -> IO ()
execute conn@(Connection {hDBC=hDBC}) query = do
pFIELD <- mallocBytes (#const sizeof(FIELD))
res <- sqlAllocStmt hDBC ((#ptr FIELD, hSTMT) pFIELD)
unless (sqlSuccess res) (free pFIELD)
handleSqlResult (#const SQL_HANDLE_DBC) hDBC res
hSTMT <- (#peek FIELD, hSTMT) pFIELD
let handleResult res = do
unless (sqlSuccess res) (free pFIELD)
handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
pQuery <- newCString query
res <- sqlExecDirect hSTMT pQuery (length query)
free pQuery
handleResult res
sqlFreeStmt hSTMT 0 >>= handleSqlResult (#const SQL_HANDLE_STMT) hSTMT
free pFIELD
query :: Connection -> String -> IO Statement
query conn@(Connection {hDBC=hDBC}) query = do
pFIELD <- mallocBytes (#const sizeof(FIELD))
res <- sqlAllocStmt hDBC ((#ptr FIELD, hSTMT) pFIELD)
unless (sqlSuccess res) (free pFIELD)
handleSqlResult (#const SQL_HANDLE_DBC) hDBC res
hSTMT <- (#peek FIELD, hSTMT) pFIELD
let handleResult res = do
unless (sqlSuccess res) (free pFIELD)
handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
pQuery <- newCString query
res <- sqlExecDirect hSTMT pQuery (length query)
free pQuery
handleResult res
sqlNumResultCols hSTMT ((#ptr FIELD, fieldsCount) pFIELD) >>= handleResult
count <- (#peek FIELD, fieldsCount) pFIELD
(fields, bufSize) <- getFieldDefs hSTMT pFIELD 1 count
free pFIELD
buffer <- mallocBytes (fromIntegral (bufSize+(#const sizeof(SQLINTEGER))))
let statement = Statement {hSTMT=hSTMT, connection=conn, fields=fields, fetchBuffer=buffer, fetchBufferSize=bufSize}
return statement
where
getFieldDefs :: HSTMT -> Ptr a -> SQLUSMALLINT -> SQLUSMALLINT -> IO ([FieldDef], SQLINTEGER)
getFieldDefs hSTMT pFIELD n count
| n > count = return ([], 0)
| otherwise = do
res <- sqlDescribeCol hSTMT n ((#ptr FIELD, fieldName) pFIELD) (#const FIELD_NAME_LENGTH) ((#ptr FIELD, NameLength) pFIELD) ((#ptr FIELD, DataType) pFIELD) ((#ptr FIELD, ColumnSize) pFIELD) ((#ptr FIELD, DecimalDigits) pFIELD) ((#ptr FIELD, Nullable) pFIELD)
unless (sqlSuccess res) (free pFIELD)
handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
name <- peekCString ((#ptr FIELD, fieldName) pFIELD)
dataType <- (#peek FIELD, DataType) pFIELD
columnSize <- (#peek FIELD, ColumnSize) pFIELD
decimalDigits <- (#peek FIELD, DecimalDigits) pFIELD
(nullable :: SQLSMALLINT) <- (#peek FIELD, Nullable) pFIELD
let (sqlType, bufSize) = mkSqlType dataType columnSize decimalDigits
(fields, fullBufSize) <- getFieldDefs hSTMT pFIELD (n+1) count
return ((name,sqlType,toBool nullable):fields, max bufSize fullBufSize)
mkSqlType :: SQLSMALLINT -> SQLULEN -> SQLSMALLINT -> (SqlType, SQLINTEGER)
mkSqlType (#const SQL_CHAR) size _ = (SqlChar (fromIntegral size), (#const sizeof(SQLCHAR))*(fromIntegral size+1))
mkSqlType (#const SQL_VARCHAR) size _ = (SqlVarChar (fromIntegral size), (#const sizeof(SQLCHAR))*(fromIntegral size+1))
mkSqlType (#const SQL_LONGVARCHAR) size _ = (SqlLongVarChar (fromIntegral size), 1) -- dummy bufSize
mkSqlType (#const SQL_DECIMAL) size prec = (SqlDecimal (fromIntegral size) (fromIntegral prec), (#const sizeof(SQLDOUBLE)))
mkSqlType (#const SQL_NUMERIC) size prec = (SqlNumeric (fromIntegral size) (fromIntegral prec), (#const sizeof(SQLDOUBLE)))
mkSqlType (#const SQL_SMALLINT) _ _ = (SqlSmallInt, (#const sizeof(SQLSMALLINT)))
mkSqlType (#const SQL_INTEGER) _ _ = (SqlInteger, (#const sizeof(SQLINTEGER)))
mkSqlType (#const SQL_REAL) _ _ = (SqlReal, (#const sizeof(SQLDOUBLE)))
mkSqlType (#const SQL_DOUBLE) _ _ = (SqlDouble, (#const sizeof(SQLDOUBLE)))
mkSqlType (#const SQL_BIT) _ _ = (SqlBit, (#const sizeof(SQLINTEGER)))
mkSqlType (#const SQL_TINYINT) _ _ = (SqlTinyInt, (#const sizeof(SQLSMALLINT)))
mkSqlType (#const SQL_BIGINT) _ _ = (SqlBigInt, (#const sizeof(SQLINTEGER)))
mkSqlType (#const SQL_BINARY) size _ = (SqlBinary (fromIntegral size), (#const sizeof(SQLCHAR))*(fromIntegral size+1))
mkSqlType (#const SQL_VARBINARY) size _ = (SqlVarBinary (fromIntegral size), (#const sizeof(SQLCHAR))*(fromIntegral size+1))
mkSqlType (#const SQL_LONGVARBINARY)size _ = (SqlLongVarBinary (fromIntegral size), 1) -- dummy bufSize
mkSqlType (#const SQL_DATE) _ _ = (SqlDate, (#const sizeof(SQL_DATE_STRUCT)))
mkSqlType (#const SQL_TIME) _ _ = (SqlTime, (#const sizeof(SQL_TIME_STRUCT)))
mkSqlType (#const SQL_TIMESTAMP) _ _ = (SqlTimeStamp, (#const sizeof(SQL_TIMESTAMP_STRUCT)))
{-# NOINLINE fetch #-}
fetch :: Statement -> IO Bool
fetch stmt = do
res <- sqlFetch (hSTMT stmt)
handleSqlResult (#const SQL_HANDLE_STMT) (hSTMT stmt) res
return (res /= (#const SQL_NO_DATA))
closeStatement :: Statement -> IO ()
closeStatement stmt = do
free (fetchBuffer stmt)
sqlFreeStmt (hSTMT stmt) 0 >>= handleSqlResult (#const SQL_HANDLE_STMT) (hSTMT stmt)
-----------------------------------------------------------------------------------------
-- transactions
-----------------------------------------------------------------------------------------
inTransaction :: Connection -> (Connection -> IO a) -> IO a
inTransaction conn@(Connection {hDBC=hDBC, environment=envRef}) action = withForeignPtr envRef $ \hEnv -> do
sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_OFF)
r <- catchSql (action conn) (\err -> do
sqlTransact hEnv hDBC (#const SQL_ROLLBACK)
sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_ON)
throwDyn err)
sqlTransact hEnv hDBC (#const SQL_COMMIT)
sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_ON)
return r
-----------------------------------------------------------------------------------------
-- binding
-----------------------------------------------------------------------------------------
class SqlBind a where
getSqlValue :: SqlType -> Ptr () -> Int -> IO a
instance SqlBind Int where
getSqlValue SqlInteger ptr size = peek (castPtr ptr)
getSqlValue SqlSmallInt ptr size = do
(n :: Int16) <- peek (castPtr ptr)
return (fromIntegral n)
instance SqlBind Integer where
getSqlValue SqlInteger ptr size = do
(n :: Int32) <- peek (castPtr ptr)
return (fromIntegral n)
getSqlValue SqlSmallInt ptr size = do
(n :: Int16) <- peek (castPtr ptr)
return (fromIntegral n)
getSqlValue SqlBigInt ptr size = do
str <- peekCStringLen (castPtr ptr, size)
return (read str)
instance SqlBind String where
getSqlValue (SqlChar _) ptr size = peekCStringLen (castPtr ptr, size)
getSqlValue (SqlVarChar _) ptr size = peekCStringLen (castPtr ptr, size)
getSqlValue (SqlLongVarChar _) ptr size = peekCStringLen (castPtr ptr, size)
instance SqlBind Double where
getSqlValue (SqlDecimal _ _) ptr size = peek (castPtr ptr)
getSqlValue (SqlNumeric _ _) ptr size = peek (castPtr ptr)
getSqlValue SqlDouble ptr size = peek (castPtr ptr)
getSqlValue SqlReal ptr size = peek (castPtr ptr)
instance SqlBind ClockTime where
getSqlValue SqlDate ptr size = allocaBytes (#const sizeof(struct tm)) $ \p_tm -> do
(year :: SQLSMALLINT) <- (#peek TIMESTAMP_STRUCT, year) ptr
(#poke struct tm,tm_year ) p_tm (fromIntegral (year-1900) :: CInt)
(month :: SQLUSMALLINT) <- (#peek TIMESTAMP_STRUCT, month) ptr
(#poke struct tm,tm_mon ) p_tm (fromIntegral (month-1) :: CInt)
(day :: SQLUSMALLINT) <- (#peek TIMESTAMP_STRUCT, day) ptr
(#poke struct tm,tm_mday) p_tm (fromIntegral day :: CInt)
(hour :: SQLUSMALLINT) <- (#peek TIMESTAMP_STRUCT, hour) ptr
(#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt)
(minute :: SQLUSMALLINT) <- (#peek TIMESTAMP_STRUCT, minute) ptr
(#poke struct tm,tm_min ) p_tm (fromIntegral minute :: CInt)
(second :: SQLUSMALLINT) <- (#peek TIMESTAMP_STRUCT, second) ptr
(#poke struct tm,tm_sec ) p_tm (fromIntegral second :: CInt)
(fraction :: SQLUINTEGER) <- (#peek TIMESTAMP_STRUCT, fraction) ptr
(#poke struct tm,tm_isdst) p_tm (-1 :: CInt)
t <- mktime p_tm
return (TOD (fromIntegral t) (fromIntegral fraction*1000))
foreign import ccall unsafe mktime :: Ptr () -> IO CTime
getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
getFieldValueMB (Statement {hSTMT=hSTMT, fields=fields, fetchBuffer=buffer, fetchBufferSize=bufferSize}) name = do
let dataBuffer = buffer `plusPtr` (#const sizeof(SQLINTEGER))
res <- sqlGetData hSTMT colNumber targetType dataBuffer bufferSize (castPtr buffer)
handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
(len_or_ind :: SQLINTEGER) <- peek (castPtr buffer)
if len_or_ind == (#const SQL_NULL_DATA)
then return Nothing
else fmap Just $
(if res == (#const SQL_SUCCESS_WITH_INFO)
then getLongData len_or_ind
else getSqlValue sqlType dataBuffer (fromIntegral len_or_ind))
where
(sqlType,nullable,colNumber) = findFieldInfo name fields 1
getLongData len = do
buffer <- mallocBytes (fromIntegral (len+(#const sizeof(SQLINTEGER))+1))
let dataBuffer = buffer `plusPtr` (#const sizeof(SQLINTEGER))
res <- sqlGetData hSTMT colNumber targetType dataBuffer (len+1) (castPtr buffer)
unless (sqlSuccess res) (free buffer)
handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
(len_or_ind :: SQLINTEGER) <- peek (castPtr buffer)
r <- getSqlValue sqlType dataBuffer (fromIntegral len_or_ind)
free buffer
return r
targetType = case sqlType of
SqlBit -> (#const SQL_C_BIT)
SqlTinyInt -> (#const SQL_C_UTINYINT)
SqlSmallInt -> (#const SQL_C_SSHORT)
SqlInteger -> (#const SQL_C_SLONG)
SqlReal -> (#const SQL_C_FLOAT)
SqlDouble -> (#const SQL_C_DOUBLE)
SqlDate -> (#const SQL_C_TIMESTAMP)
SqlTime -> (#const SQL_C_TIMESTAMP)
SqlTimeStamp -> (#const SQL_C_TIMESTAMP)
SqlNumeric _ _ -> (#const SQL_C_DOUBLE)
SqlDecimal _ _ -> (#const SQL_C_DOUBLE)
SqlBigInt -> (#const SQL_C_CHAR)
SqlChar _ -> (#const SQL_C_CHAR)
SqlVarChar _ -> (#const SQL_C_CHAR)
SqlBinary _ -> (#const SQL_C_BINARY)
SqlVarBinary _ -> (#const SQL_C_BINARY)
SqlLongVarChar _ -> (#const SQL_C_CHAR)
SqlLongVarBinary _ -> (#const SQL_C_BINARY)
getFieldValue :: SqlBind a => Statement -> String -> IO a
getFieldValue stmt name = do
mb_v <- getFieldValueMB stmt name
case mb_v of
Nothing -> fail ("Column \"" ++ name ++ "\" has null value")
Just a -> return a
getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a
getFieldValue' stmt name def = do
mb_v <- getFieldValueMB stmt name
return (case mb_v of { Nothing -> def; Just a -> a })
getFieldValueType :: Statement -> String -> (SqlType, Bool)
getFieldValueType stmt name = (sqlType, nullable)
where
(sqlType,nullable,colNumber) = findFieldInfo name (fields stmt) 1
getFieldsTypes :: Statement -> [(String, SqlType, Bool)]
getFieldsTypes = fields
findFieldInfo :: String -> [FieldDef] -> SQLUSMALLINT -> (SqlType,Bool,SQLUSMALLINT)
findFieldInfo name [] colNumber = error ("Undefined column name \"" ++ name ++ "\"")
findFieldInfo name (fieldDef@(name',sqlType,nullable):fields) colNumber
| name == name' = (sqlType,nullable,colNumber)
| otherwise = findFieldInfo name fields (colNumber+1)
-----------------------------------------------------------------------------------------
-- helpers
-----------------------------------------------------------------------------------------
forEachRow :: (Statement -> s -> IO s) -> Statement -> s -> IO s
forEachRow f stmt s = do
success <- fetch stmt
if success then f stmt s >>= forEachRow f stmt else closeStatement stmt >> return s
forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()
forEachRow' f stmt = do
success <- fetch stmt
if success then f stmt >> forEachRow' f stmt else closeStatement stmt
collectRows :: (Statement -> IO a) -> Statement -> IO [a]
collectRows f stmt = loop
where
loop = do
success <- fetch stmt
if success
then do
x <- f stmt
xs <- loop
return (x:xs)
else closeStatement stmt >> return []
--- NEW FILE: HSQLStructs.h ---
#ifdef WIN32
#include <windows.h>
#endif
#include <sqlext.h>
#define FIELD_NAME_LENGTH 255
typedef struct
{
HSTMT hSTMT;
SQLUSMALLINT fieldsCount;
SQLCHAR fieldName[FIELD_NAME_LENGTH];
SQLSMALLINT NameLength;
SQLSMALLINT DataType;
SQLULEN ColumnSize;
SQLSMALLINT DecimalDigits;
SQLSMALLINT Nullable;
} FIELD;
#ifdef WIN32
void sqlFreeEnv(HENV hEnv);
#else
#define sqlFreeEnv SQLFreeEnv
#endif
|
|
From: <kr_...@us...> - 2003-09-05 21:40:40
|
Update of /cvsroot/htoolkit/HSQL/ODBC In directory sc8-pr-cvs1:/tmp/cvs-serv9129/ODBC Log Message: Directory /cvsroot/htoolkit/HSQL/ODBC added to the repository |
|
From: <kr_...@us...> - 2003-09-05 11:38:02
|
Update of /cvsroot/htoolkit/HSQL
In directory sc8-pr-cvs1:/tmp/cvs-serv12029
Added Files:
Makefile config.guess config.mk.in config.sub configure.ac
hsql.pkg.in install-sh
Log Message:
Basic build system for HSQL
--- NEW FILE: Makefile ---
include config.mk
ifeq "$(WithODBC)" "YES"
HS_SRC += src/ODBC/HSQL.hs
CPPFLAGS += -Isrc/ODBC
endif
ifeq "$(WithPostgreSQL)" "YES"
HS_SRC += src/PostgreSQL/HSQL.hs
endif
ifeq "$(WithMySQL)" "YES"
HS_SRC += src/MySQL/HSQL.hs
endif
OBJS = $(patsubst %.hs,%.o, $(HS_SRC))
HI_SRC = $(patsubst %.hs,%.hi,$(HS_SRC))
HS_PPS = $(addsuffix .raw-hs, $(basename $(HS_SRC)))
%.o : %.hs
$(GHC) $< $($*_HC_OPTS) -O -c -fglasgow-exts -Iincludes $(CPPFLAGS) -package-name HToolkit
%.hs : %.hsc
$(HSC2HS) $< -Iincludes $(CPPFLAGS)
%.hi : %.o
@
%.raw-hs : %.hs
$(GHC) -Iincludes $(CPPFLAGS) -D__HADDOCK__ -E -cpp $< -o $<.tmp && sed -e 's/^#.*//' <$<.tmp >$@
all: $(OBJS)
echo $(HS_SRC)
rm -f libHSsql.a
$(AR) -q libHSsql.a $^
depend: $(HS_SRC)
$(GHC) -M $^
clean:
rm -f $(OBJS)
rm -f $(HI_SRC)
rm -f $(HS_PPS)
doc : $(HS_PPS)
mkdir -p doc
$(HADDOCK) -h -o doc $(HS_PPS)
install: libHSsql.a $(HI_SRC)
$(INSTALL) libHSsql.a $(prefix)/libHSsql.a
$(INSTALL) -d $(prefix)/imports/hsql
for i in $(HI_SRC); do \
$(INSTALL) -d $(prefix)/imports/hsql/`dirname $$i`; \
$(INSTALL) -c $$i $(prefix)/imports/hsql/`dirname $$i`; \
done
$(GHC_PKG) -u -g -i hsql.pkg.in
--- NEW FILE: config.guess ---
#! /bin/sh
# Attempt to guess a canonical system name.
# Copyright (C) 1992, 93, 94, 95, 96, 97, 1998 Free Software Foundation, Inc.
#
# This file 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.
#
# 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.
# Written by Per Bothner <bo...@cy...>.
# The master version of this file is at the FSF in /home/gd/gnu/lib.
#
# This script attempts to guess a canonical system name similar to
# config.sub. If it succeeds, it prints the system name on stdout, and
# exits with 0. Otherwise, it exits with 1.
#
# The plan is that this can be called by configure scripts if you
# don't specify an explicit system type (host/target name).
#
# Only a few systems have been added to this list; please add others
# (but try to keep the structure clean).
#
# This is needed to find uname on a Pyramid OSx when run in the BSD universe.
# (gh...@no... 8/24/94.)
if (test -f /.attbin/uname) >/dev/null 2>&1 ; then
PATH=$PATH:/.attbin ; export PATH
fi
UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown
UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown
trap 'rm -f dummy.c dummy.o dummy; exit 1' 1 2 15
# Note: order is significant - the case branches are not exclusive.
case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
alpha:OSF1:*:*)
if test $UNAME_RELEASE = "V4.0"; then
UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'`
fi
# A Vn.n version is a released version.
# A Tn.n version is a released field test version.
# A Xn.n version is an unreleased experimental baselevel.
# 1.2 uses "1.2" for uname -r.
cat <<EOF >dummy.s
.globl main
.ent main
main:
.frame \$30,0,\$26,0
.prologue 0
.long 0x47e03d80 # implver $0
lda \$2,259
.long 0x47e20c21 # amask $2,$1
srl \$1,8,\$2
sll \$2,2,\$2
sll \$0,3,\$0
addl \$1,\$0,\$0
addl \$2,\$0,\$0
ret \$31,(\$26),1
.end main
EOF
${CC-cc} dummy.s -o dummy 2>/dev/null
if test "$?" = 0 ; then
./dummy
case "$?" in
7)
UNAME_MACHINE="alpha"
;;
15)
UNAME_MACHINE="alphaev5"
;;
14)
UNAME_MACHINE="alphaev56"
;;
10)
UNAME_MACHINE="alphapca56"
;;
16)
UNAME_MACHINE="alphaev6"
;;
esac
fi
rm -f dummy.s dummy
echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[VTX]//' | tr [[A-Z]] [[a-z]]`
exit 0 ;;
21064:Windows_NT:50:3)
echo alpha-dec-winnt3.5
exit 0 ;;
Amiga*:UNIX_System_V:4.0:*)
echo m68k-cbm-sysv4
exit 0;;
amiga:NetBSD:*:*)
echo m68k-cbm-netbsd${UNAME_RELEASE}
exit 0 ;;
amiga:OpenBSD:*:*)
echo m68k-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
*:[Aa]miga[Oo][Ss]:*:*)
echo ${UNAME_MACHINE}-unknown-amigaos
exit 0 ;;
arc64:OpenBSD:*:*)
echo mips64el-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
arc:OpenBSD:*:*)
echo mipsel-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
hkmips:OpenBSD:*:*)
echo mips-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
pmax:OpenBSD:*:*)
echo mipsel-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
sgi:OpenBSD:*:*)
echo mips-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
wgrisc:OpenBSD:*:*)
echo mipsel-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
echo arm-acorn-riscix${UNAME_RELEASE}
exit 0;;
arm32:NetBSD:*:*)
echo arm-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
exit 0 ;;
SR2?01:HI-UX/MPP:*:*)
echo hppa1.1-hitachi-hiuxmpp
exit 0;;
Pyramid*:OSx*:*:*|MIS*:OSx*:*:*|MIS*:SMP_DC-OSx*:*:*)
# ak...@wp... (Earle F. Ake) contributed MIS and NILE.
if test "`(/bin/universe) 2>/dev/null`" = att ; then
echo pyramid-pyramid-sysv3
else
echo pyramid-pyramid-bsd
fi
exit 0 ;;
NILE:*:*:dcosx)
echo pyramid-pyramid-svr4
exit 0 ;;
sun4H:SunOS:5.*:*)
echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
exit 0 ;;
sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*)
echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
exit 0 ;;
i86pc:SunOS:5.*:*)
echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
exit 0 ;;
sun4*:SunOS:6*:*)
# According to config.sub, this is the proper way to canonicalize
# SunOS6. Hard to guess exactly what SunOS6 will be like, but
# it's likely to be more like Solaris than SunOS4.
echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
exit 0 ;;
sun4*:SunOS:*:*)
case "`/usr/bin/arch -k`" in
Series*|S4*)
UNAME_RELEASE=`uname -v`
;;
esac
# Japanese Language versions have a version number like `4.1.3-JL'.
echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
exit 0 ;;
sun3*:SunOS:*:*)
echo m68k-sun-sunos${UNAME_RELEASE}
exit 0 ;;
sun*:*:4.2BSD:*)
UNAME_RELEASE=`(head -1 /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null`
test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3
case "`/bin/arch`" in
sun3)
echo m68k-sun-sunos${UNAME_RELEASE}
;;
sun4)
echo sparc-sun-sunos${UNAME_RELEASE}
;;
esac
exit 0 ;;
aushp:SunOS:*:*)
echo sparc-auspex-sunos${UNAME_RELEASE}
exit 0 ;;
atari*:NetBSD:*:*)
echo m68k-atari-netbsd${UNAME_RELEASE}
exit 0 ;;
atari*:OpenBSD:*:*)
echo m68k-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
sun3*:NetBSD:*:*)
echo m68k-sun-netbsd${UNAME_RELEASE}
exit 0 ;;
sun3*:OpenBSD:*:*)
echo m68k-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
mac68k:NetBSD:*:*)
echo m68k-apple-netbsd${UNAME_RELEASE}
exit 0 ;;
mac68k:OpenBSD:*:*)
echo m68k-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
mvme68k:OpenBSD:*:*)
echo m68k-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
mvme88k:OpenBSD:*:*)
echo m88k-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
powerpc:machten:*:*)
echo powerpc-apple-machten${UNAME_RELEASE}
exit 0 ;;
Power*:Darwin:*:*)
echo powerpc-apple-macosx${UNAME_RELEASE}
exit 0 ;;
macppc:NetBSD:*:*)
echo powerpc-apple-netbsd${UNAME_RELEASE}
exit 0 ;;
RISC*:Mach:*:*)
echo mips-dec-mach_bsd4.3
exit 0 ;;
RISC*:ULTRIX:*:*)
echo mips-dec-ultrix${UNAME_RELEASE}
exit 0 ;;
VAX*:ULTRIX*:*:*)
echo vax-dec-ultrix${UNAME_RELEASE}
exit 0 ;;
2020:CLIX:*:*)
echo clipper-intergraph-clix${UNAME_RELEASE}
exit 0 ;;
mips:*:*:UMIPS | mips:*:*:RISCos)
sed 's/^ //' << EOF >dummy.c
int main (argc, argv) int argc; char **argv; {
#if defined (host_mips) && defined (MIPSEB)
#if defined (SYSTYPE_SYSV)
printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0);
#endif
#if defined (SYSTYPE_SVR4)
printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0);
#endif
#if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD)
printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0);
#endif
#endif
exit (-1);
}
EOF
${CC-cc} dummy.c -o dummy \
&& ./dummy `echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` \
&& rm dummy.c dummy && exit 0
rm -f dummy.c dummy
echo mips-mips-riscos${UNAME_RELEASE}
exit 0 ;;
Night_Hawk:Power_UNIX:*:*)
echo powerpc-harris-powerunix
exit 0 ;;
m88k:CX/UX:7*:*)
echo m88k-harris-cxux7
exit 0 ;;
m88k:*:4*:R4*)
echo m88k-motorola-sysv4
exit 0 ;;
m88k:*:3*:R3*)
echo m88k-motorola-sysv3
exit 0 ;;
AViiON:dgux:*:*)
# DG/UX returns AViiON for all architectures
UNAME_PROCESSOR=`/usr/bin/uname -p`
if [ $UNAME_PROCESSOR = mc88100 -o $UNAME_PROCESSOR = mc88110 ] ; then
if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx \
-o ${TARGET_BINARY_INTERFACE}x = x ] ; then
echo m88k-dg-dgux${UNAME_RELEASE}
else
echo m88k-dg-dguxbcs${UNAME_RELEASE}
fi
else echo i586-dg-dgux${UNAME_RELEASE}
fi
exit 0 ;;
M88*:DolphinOS:*:*) # DolphinOS (SVR3)
echo m88k-dolphin-sysv3
exit 0 ;;
M88*:*:R3*:*)
# Delta 88k system running SVR3
echo m88k-motorola-sysv3
exit 0 ;;
XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)
echo m88k-tektronix-sysv3
exit 0 ;;
Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)
echo m68k-tektronix-bsd
exit 0 ;;
*:IRIX*:*:*)
echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'`
exit 0 ;;
????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX.
echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id
exit 0 ;; # Note that: echo "'`uname -s`'" gives 'AIX '
i?86:AIX:*:*)
echo i386-ibm-aix
exit 0 ;;
*:AIX:2:3)
if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
sed 's/^ //' << EOF >dummy.c
#include <sys/systemcfg.h>
main()
{
if (!__power_pc())
exit(1);
puts("powerpc-ibm-aix3.2.5");
exit(0);
}
EOF
${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0
rm -f dummy.c dummy
echo rs6000-ibm-aix3.2.5
elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then
echo rs6000-ibm-aix3.2.4
else
echo rs6000-ibm-aix3.2
fi
exit 0 ;;
*:AIX:*:4)
IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | head -1 | awk '{ print $1 }'`
if /usr/sbin/lsattr -EHl ${IBM_CPU_ID} | grep POWER >/dev/null 2>&1; then
IBM_ARCH=rs6000
else
IBM_ARCH=powerpc
fi
if [ -x /usr/bin/oslevel ] ; then
IBM_REV=`/usr/bin/oslevel`
else
IBM_REV=4.${UNAME_RELEASE}
fi
echo ${IBM_ARCH}-ibm-aix${IBM_REV}
exit 0 ;;
*:AIX:*:*)
echo rs6000-ibm-aix
exit 0 ;;
ibmrt:4.4BSD:*|romp-ibm:BSD:*)
echo romp-ibm-bsd4.4
exit 0 ;;
ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC NetBSD and
echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to
exit 0 ;; # report: romp-ibm BSD 4.3
*:BOSX:*:*)
echo rs6000-bull-bosx
exit 0 ;;
DPX/2?00:B.O.S.:*:*)
echo m68k-bull-sysv3
exit 0 ;;
9000/[34]??:4.3bsd:1.*:*)
echo m68k-hp-bsd
exit 0 ;;
hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)
echo m68k-hp-bsd4.4
exit 0 ;;
9000/[34678]??:HP-UX:*:*)
case "${UNAME_MACHINE}" in
9000/31? ) HP_ARCH=m68000 ;;
9000/[34]?? ) HP_ARCH=m68k ;;
9000/6?? | 9000/7?? | 9000/80[24] | 9000/8?[13679] | 9000/892 )
sed 's/^ //' << EOF >dummy.c
#include <stdlib.h>
#include <unistd.h>
int main ()
{
#if defined(_SC_KERNEL_BITS)
long bits = sysconf(_SC_KERNEL_BITS);
#endif
long cpu = sysconf (_SC_CPU_VERSION);
switch (cpu)
{
case CPU_PA_RISC1_0: puts ("hppa1.0"); break;
case CPU_PA_RISC1_1: puts ("hppa1.1"); break;
case CPU_PA_RISC2_0:
#if defined(_SC_KERNEL_BITS)
switch (bits)
{
case 64: puts ("hppa2.0w"); break;
case 32: puts ("hppa2.0n"); break;
default: puts ("hppa2.0"); break;
} break;
#else /* !defined(_SC_KERNEL_BITS) */
puts ("hppa2.0"); break;
#endif
default: puts ("hppa1.0"); break;
}
exit (0);
}
EOF
(${CC-cc} dummy.c -o dummy 2>/dev/null ) && HP_ARCH=`./dummy`
rm -f dummy.c dummy
esac
HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
echo ${HP_ARCH}-hp-hpux${HPUX_REV}
exit 0 ;;
3050*:HI-UX:*:*)
sed 's/^ //' << EOF >dummy.c
#include <unistd.h>
int
main ()
{
long cpu = sysconf (_SC_CPU_VERSION);
/* The order matters, because CPU_IS_HP_MC68K erroneously returns
true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct
results, however. */
if (CPU_IS_PA_RISC (cpu))
{
switch (cpu)
{
case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break;
case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break;
case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break;
default: puts ("hppa-hitachi-hiuxwe2"); break;
}
}
else if (CPU_IS_HP_MC68K (cpu))
puts ("m68k-hitachi-hiuxwe2");
else puts ("unknown-hitachi-hiuxwe2");
exit (0);
}
EOF
${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0
rm -f dummy.c dummy
echo unknown-hitachi-hiuxwe2
exit 0 ;;
9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* )
echo hppa1.1-hp-bsd
exit 0 ;;
9000/8??:4.3bsd:*:*)
echo hppa1.0-hp-bsd
exit 0 ;;
hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* )
echo hppa1.1-hp-osf
exit 0 ;;
hp8??:OSF1:*:*)
echo hppa1.0-hp-osf
exit 0 ;;
i?86:OSF1:*:*)
if [ -x /usr/sbin/sysversion ] ; then
echo ${UNAME_MACHINE}-unknown-osf1mk
else
echo ${UNAME_MACHINE}-unknown-osf1
fi
exit 0 ;;
parisc*:Lites*:*:*)
echo hppa1.1-hp-lites
exit 0 ;;
C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
echo c1-convex-bsd
exit 0 ;;
C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)
if getsysinfo -f scalar_acc
then echo c32-convex-bsd
else echo c2-convex-bsd
fi
exit 0 ;;
C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)
echo c34-convex-bsd
exit 0 ;;
C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)
echo c38-convex-bsd
exit 0 ;;
C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
echo c4-convex-bsd
exit 0 ;;
CRAY*X-MP:*:*:*)
echo xmp-cray-unicos
exit 0 ;;
CRAY*Y-MP:*:*:*)
echo ymp-cray-unicos${UNAME_RELEASE}
exit 0 ;;
CRAY*[A-Z]90:*:*:*)
echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \
| sed -e 's/CRAY.*\([A-Z]90\)/\1/' \
-e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/
exit 0 ;;
CRAY*TS:*:*:*)
echo t90-cray-unicos${UNAME_RELEASE}
exit 0 ;;
CRAY-2:*:*:*)
echo cray2-cray-unicos
exit 0 ;;
F300:UNIX_System_V:*:*)
FUJITSU_SYS=`uname -p | tr [A-Z] [a-z] | sed -e 's/\///'`
FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'`
echo "f300-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}"
exit 0 ;;
F301:UNIX_System_V:*:*)
echo f301-fujitsu-uxpv`echo $UNAME_RELEASE | sed 's/ .*//'`
exit 0 ;;
hp3[0-9][05]:NetBSD:*:*)
echo m68k-hp-netbsd${UNAME_RELEASE}
exit 0 ;;
hp300:OpenBSD:*:*)
echo m68k-unknown-openbsd${UNAME_RELEASE}
exit 0 ;;
sparc*:BSD/OS:*:*)
echo sparc-unknown-bsdi${UNAME_RELEASE}
exit 0 ;;
i?86:BSD/386:*:* | *:BSD/OS:*:*)
echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE}
exit 0 ;;
*:FreeBSD:*:*)
echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
exit 0 ;;
*:NetBSD:*:*)
echo ${UNAME_MACHINE}-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
exit 0 ;;
*:OpenBSD:*:*)
echo ${UNAME_MACHINE}-unknown-openbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
exit 0 ;;
i*:CYGWIN*:*)
echo ${UNAME_MACHINE}-pc-cygwin
exit 0 ;;
i*:MINGW*:*)
echo ${UNAME_MACHINE}-pc-mingw32
exit 0 ;;
p*:CYGWIN*:*)
echo powerpcle-unknown-cygwin
exit 0 ;;
prep*:SunOS:5.*:*)
echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
exit 0 ;;
*:GNU:*:*)
echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
exit 0 ;;
*:Linux:*:*)
# uname on the ARM produces all sorts of strangeness, and we need to
# filter it out.
case "$UNAME_MACHINE" in
arm* | sa110*) UNAME_MACHINE="arm" ;;
esac
# The BFD linker knows what the default object file format is, so
# first see if it will tell us.
ld_help_string=`ld --help 2>&1`
ld_supported_emulations=`echo $ld_help_string \
| sed -ne '/supported emulations:/!d
s/[ ][ ]*/ /g
s/.*supported emulations: *//
s/ .*//
p'`
case "$ld_supported_emulations" in
i?86linux) echo "${UNAME_MACHINE}-pc-linux-gnuaout" ; exit 0 ;;
i?86coff) echo "${UNAME_MACHINE}-pc-linux-gnucoff" ; exit 0 ;;
sparclinux) echo "${UNAME_MACHINE}-unknown-linux-gnuaout" ; exit 0 ;;
armlinux) echo "${UNAME_MACHINE}-unknown-linux-gnuaout" ; exit 0 ;;
m68klinux) echo "${UNAME_MACHINE}-unknown-linux-gnuaout" ; exit 0 ;;
elf32ppc) echo "powerpc-unknown-linux-gnu" ; exit 0 ;;
esac
if test "${UNAME_MACHINE}" = "alpha" ; then
sed 's/^ //' <<EOF >dummy.s
.globl main
.ent main
main:
.frame \$30,0,\$26,0
.prologue 0
.long 0x47e03d80 # implver $0
lda \$2,259
.long 0x47e20c21 # amask $2,$1
srl \$1,8,\$2
sll \$2,2,\$2
sll \$0,3,\$0
addl \$1,\$0,\$0
addl \$2,\$0,\$0
ret \$31,(\$26),1
.end main
EOF
LIBC=""
${CC-cc} dummy.s -o dummy 2>/dev/null
if test "$?" = 0 ; then
./dummy
case "$?" in
7)
UNAME_MACHINE="alpha"
;;
15)
UNAME_MACHINE="alphaev5"
;;
14)
UNAME_MACHINE="alphaev56"
;;
10)
UNAME_MACHINE="alphapca56"
;;
16)
UNAME_MACHINE="alphaev6"
;;
esac
objdump --private-headers dummy | \
grep ld.so.1 > /dev/null
if test "$?" = 0 ; then
LIBC="libc1"
fi
fi
rm -f dummy.s dummy
echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} ; exit 0
elif test "${UNAME_MACHINE}" = "mips" ; then
cat >dummy.c <<EOF
main(argc, argv)
int argc;
char *argv[];
{
#ifdef __MIPSEB__
printf ("%s-unknown-linux-gnu\n", argv[1]);
#endif
#ifdef __MIPSEL__
printf ("%sel-unknown-linux-gnu\n", argv[1]);
#endif
return 0;
}
EOF
${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy "${UNAME_MACHINE}" && rm dummy.c dummy && exit 0
rm -f dummy.c dummy
else
# Either a pre-BFD a.out linker (linux-gnuoldld)
# or one that does not give us useful --help.
# GCC wants to distinguish between linux-gnuoldld and linux-gnuaout.
# If ld does not provide *any* "supported emulations:"
# that means it is gnuoldld.
echo "$ld_help_string" | grep >/dev/null 2>&1 "supported emulations:"
test $? != 0 && echo "${UNAME_MACHINE}-pc-linux-gnuoldld" && exit 0
case "${UNAME_MACHINE}" in
i?86)
VENDOR=pc;
;;
*)
VENDOR=unknown;
;;
esac
# Determine whether the default compiler is a.out or elf
cat >dummy.c <<EOF
#include <features.h>
main(argc, argv)
int argc;
char *argv[];
{
#ifdef __ELF__
# ifdef __GLIBC__
# if __GLIBC__ >= 2
printf ("%s-${VENDOR}-linux-gnu\n", argv[1]);
# else
printf ("%s-${VENDOR}-linux-gnulibc1\n", argv[1]);
# endif
# else
printf ("%s-${VENDOR}-linux-gnulibc1\n", argv[1]);
# endif
#else
printf ("%s-${VENDOR}-linux-gnuaout\n", argv[1]);
#endif
return 0;
}
EOF
${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy "${UNAME_MACHINE}" && rm dummy.c dummy && exit 0
rm -f dummy.c dummy
fi ;;
# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. earlier versions
# are messed up and put the nodename in both sysname and nodename.
i?86:DYNIX/ptx:4*:*)
echo i386-sequent-sysv4
exit 0 ;;
i?86:UNIX_SV:4.2MP:2.*)
# Unixware is an offshoot of SVR4, but it has its own version
# number series starting with 2...
# I am not positive that other SVR4 systems won't match this,
# I just have to hope. -- rms.
# Use sysv4.2uw... so that sysv4* matches it.
echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION}
exit 0 ;;
i?86:*:4.*:* | i?86:SYSTEM_V:4.*:*)
if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
echo ${UNAME_MACHINE}-univel-sysv${UNAME_RELEASE}
else
echo ${UNAME_MACHINE}-pc-sysv${UNAME_RELEASE}
fi
exit 0 ;;
i?86:*:3.2:*)
if test -f /usr/options/cb.name; then
UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
echo ${UNAME_MACHINE}-pc-isc$UNAME_REL
elif /bin/uname -X 2>/dev/null >/dev/null ; then
UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')`
(/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486
(/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \
&& UNAME_MACHINE=i586
echo ${UNAME_MACHINE}-pc-sco$UNAME_REL
else
echo ${UNAME_MACHINE}-pc-sysv32
fi
exit 0 ;;
i?86:UnixWare:*:*)
if /bin/uname -X 2>/dev/null >/dev/null ; then
(/bin/uname -X|egrep '^Machine.*Pentium' >/dev/null) \
&& UNAME_MACHINE=i586
fi
echo ${UNAME_MACHINE}-unixware-${UNAME_RELEASE}-${UNAME_VERSION}
exit 0 ;;
pc:*:*:*)
# uname -m prints for DJGPP always 'pc', but it prints nothing about
# the processor, so we play safe by assuming i386.
echo i386-pc-msdosdjgpp
exit 0 ;;
Intel:Mach:3*:*)
echo i386-pc-mach3
exit 0 ;;
paragon:*:*:*)
echo i860-intel-osf1
exit 0 ;;
i860:*:4.*:*) # i860-SVR4
if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then
echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4
else # Add other i860-SVR4 vendors below as they are discovered.
echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4
fi
exit 0 ;;
mini*:CTIX:SYS*5:*)
# "miniframe"
echo m68010-convergent-sysv
exit 0 ;;
M68*:*:R3V[567]*:*)
test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;;
3[34]??:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 4850:*:4.0:3.0)
OS_REL=''
test -r /etc/.relid \
&& OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid`
/bin/uname -p 2>/dev/null | grep 86 >/dev/null \
&& echo i486-ncr-sysv4.3${OS_REL} && exit 0
/bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \
&& echo i586-ncr-sysv4.3${OS_REL} && exit 0 ;;
3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
/bin/uname -p 2>/dev/null | grep 86 >/dev/null \
&& echo i486-ncr-sysv4 && exit 0 ;;
m68*:LynxOS:2.*:*)
echo m68k-unknown-lynxos${UNAME_RELEASE}
exit 0 ;;
mc68030:UNIX_System_V:4.*:*)
echo m68k-atari-sysv4
exit 0 ;;
i?86:LynxOS:2.*:*)
echo i386-unknown-lynxos${UNAME_RELEASE}
exit 0 ;;
TSUNAMI:LynxOS:2.*:*)
echo sparc-unknown-lynxos${UNAME_RELEASE}
exit 0 ;;
rs6000:LynxOS:2.*:* | PowerPC:LynxOS:2.*:*)
echo rs6000-unknown-lynxos${UNAME_RELEASE}
exit 0 ;;
SM[BE]S:UNIX_SV:*:*)
echo mips-dde-sysv${UNAME_RELEASE}
exit 0 ;;
RM*:SINIX-*:*:*)
echo mips-sni-sysv4
exit 0 ;;
*:SINIX-*:*:*)
if uname -p 2>/dev/null >/dev/null ; then
UNAME_MACHINE=`(uname -p) 2>/dev/null`
echo ${UNAME_MACHINE}-sni-sysv4
else
echo ns32k-sni-sysv
fi
exit 0 ;;
PENTIUM:CPunix:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort
# says <Ric...@cc...>
echo i586-unisys-sysv4
exit 0 ;;
*:UNIX_System_V:4*:FTX*)
# From Gerald Hewes <he...@op...>.
# How about differentiating between stratus architectures? -djm
echo hppa1.1-stratus-sysv4
exit 0 ;;
*:*:*:FTX*)
# From se...@sw....
echo i860-stratus-sysv4
exit 0 ;;
mc68*:A/UX:*:*)
echo m68k-apple-aux${UNAME_RELEASE}
exit 0 ;;
news*:NEWS-OS:*:6*)
echo mips-sony-newsos6
exit 0 ;;
R3000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R4000:UNIX_SV:*:*)
if [ -d /usr/nec ]; then
echo mips-nec-sysv${UNAME_RELEASE}
else
echo mips-unknown-sysv${UNAME_RELEASE}
fi
exit 0 ;;
BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only.
echo powerpc-be-beos
exit 0 ;;
BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only.
echo powerpc-apple-beos
exit 0 ;;
BePC:BeOS:*:*) # BeOS running on Intel PC compatible.
echo i586-pc-beos
exit 0 ;;
esac
#echo '(No uname command or uname output not recognized.)' 1>&2
#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2
cat >dummy.c <<EOF
#ifdef _SEQUENT_
# include <sys/types.h>
# include <sys/utsname.h>
#endif
main ()
{
#if defined (sony)
#if defined (MIPSEB)
/* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed,
I don't know.... */
printf ("mips-sony-bsd\n"); exit (0);
#else
#include <sys/param.h>
printf ("m68k-sony-newsos%s\n",
#ifdef NEWSOS4
"4"
#else
""
#endif
); exit (0);
#endif
#endif
#if defined (__arm) && defined (__acorn) && defined (__unix)
printf ("arm-acorn-riscix"); exit (0);
#endif
#if defined (hp300) && !defined (hpux)
printf ("m68k-hp-bsd\n"); exit (0);
#endif
#if defined (NeXT)
#if !defined (__ARCHITECTURE__)
#define __ARCHITECTURE__ "m68k"
#endif
int version;
version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version);
exit (0);
#endif
#if defined (MULTIMAX) || defined (n16)
#if defined (UMAXV)
printf ("ns32k-encore-sysv\n"); exit (0);
#else
#if defined (CMU)
printf ("ns32k-encore-mach\n"); exit (0);
#else
printf ("ns32k-encore-bsd\n"); exit (0);
#endif
#endif
#endif
#if defined (__386BSD__)
printf ("i386-pc-bsd\n"); exit (0);
#endif
#if defined (sequent)
#if defined (i386)
printf ("i386-sequent-dynix\n"); exit (0);
#endif
#if defined (ns32000)
printf ("ns32k-sequent-dynix\n"); exit (0);
#endif
#endif
#if defined (_SEQUENT_)
struct utsname un;
uname(&un);
if (strncmp(un.version, "V2", 2) == 0) {
printf ("i386-sequent-ptx2\n"); exit (0);
}
if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */
printf ("i386-sequent-ptx1\n"); exit (0);
}
printf ("i386-sequent-ptx\n"); exit (0);
#endif
#if defined (vax)
#if !defined (ultrix)
printf ("vax-dec-bsd\n"); exit (0);
#else
printf ("vax-dec-ultrix\n"); exit (0);
#endif
#endif
#if defined (alliant) && defined (i860)
printf ("i860-alliant-bsd\n"); exit (0);
#endif
exit (1);
}
EOF
${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy && rm dummy.c dummy && exit 0
rm -f dummy.c dummy
# Apollos put the system type in the environment.
test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; }
# Convex versions that predate uname can use getsysinfo(1)
if [ -x /usr/convex/getsysinfo ]
then
case `getsysinfo -f cpu_type` in
c1*)
echo c1-convex-bsd
exit 0 ;;
c2*)
if getsysinfo -f scalar_acc
then echo c32-convex-bsd
else echo c2-convex-bsd
fi
exit 0 ;;
c34*)
echo c34-convex-bsd
exit 0 ;;
c38*)
echo c38-convex-bsd
exit 0 ;;
c4*)
echo c4-convex-bsd
exit 0 ;;
esac
fi
#echo '(Unable to guess system type)' 1>&2
exit 1
--- NEW FILE: config.mk.in ---
WithODBC=@WithODBC@
WithPostgreSQL=@WithPostgreSQL@
WithMySQL=@WithMySQL@
GHC = @GHC@
HSC2HS = @HSC2HS@
AR = @AR@
LD = @LD@
INSTALL = @INSTALL@
GHC_PKG = @GHC_PKG@
prefix = @prefix@
exec_prefix = @exec_prefix@
CPPFLAGS = @CPPFLAGS@
HADDOCK = @HADDOCK@
--- NEW FILE: config.sub ---
#! /bin/sh
#---------------------------------------------------------------------
# Modified and adapted for the Lazy Virtual Machine by Daan Leijen.
# + added better "windows" support
#---------------------------------------------------------------------
# $Id: config.sub,v 1.1 2003/09/05 11:37:55 kr_angelov Exp $
# Configuration validation subroutine script, version 1.1.
# Copyright (C) 1991, 92-97, 1998 Free Software Foundation, Inc.
# This file is (in principle) common to ALL GNU software.
# The presence of a machine in this file suggests that SOME GNU software
# can handle that machine. It does not imply ALL GNU software can.
#
# This file 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.
# 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.
# Configuration subroutine to validate and canonicalize a configuration type.
# Supply the specified configuration type as an argument.
# If it is invalid, we print an error message on stderr and exit with code 1.
# Otherwise, we print the canonical config type on stdout and succeed.
# This file is supposed to be the same for all GNU packages
# and recognize all the CPU types, system types and aliases
# that are meaningful with *any* GNU software.
# Each package is responsible for reporting which valid configurations
# it does not support. The user should be able to distinguish
# a failure to support a valid configuration from a meaningless
# configuration.
# The goal of this file is to map all the various variations of a given
# machine specification into a single specification in the form:
# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
# or in some cases, the newer four-part form:
# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM
# It is wrong to echo any other type of specification.
if [ x$1 = x ]
then
echo Configuration name missing. 1>&2
echo "Usage: $0 CPU-MFR-OPSYS" 1>&2
echo "or $0 ALIAS" 1>&2
echo where ALIAS is a recognized configuration type. 1>&2
exit 1
fi
# First pass through any local machine types.
case $1 in
*local*)
echo $1
exit 0
;;
*)
;;
esac
# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any).
# Here we must recognize all the valid KERNEL-OS combinations.
maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'`
case $maybe_os in
linux-gnu*)
os=-$maybe_os
basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'`
;;
*)
basic_machine=`echo $1 | sed 's/-[^-]*$//'`
if [ $basic_machine != $1 ]
then os=`echo $1 | sed 's/.*-/-/'`
else os=; fi
;;
esac
### Let's recognize common machines as not being operating systems so
### that things like config.sub decstation-3100 work. We also
### recognize some manufacturers as not being operating systems, so we
### can provide default operating systems below.
case $os in
-sun*os*)
# Prevent following clause from handling this invalid input.
;;
-dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \
-att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \
-unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \
-convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
-c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
-harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \
-apple)
os=
basic_machine=$1
;;
-hiux*)
os=-hiuxwe2
;;
-sco5)
os=sco3.2v5
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco4)
os=-sco3.2v4
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco3.2.[4-9]*)
os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco3.2v[4-9]*)
# Don't forget version if it is 3.2v4 or newer.
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-sco*)
os=-sco3.2v2
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-isc)
os=-isc2.2
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-clix*)
basic_machine=clipper-intergraph
;;
-isc*)
basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'`
;;
-lynx*)
os=-lynxos
;;
-ptx*)
basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`
;;
-windowsnt*)
os=`echo $os | sed -e 's/windowsnt/winnt/'`
;;
-psos*)
os=-psos
;;
esac
# Decode aliases for certain CPU-COMPANY combinations.
case $basic_machine in
# Recognize the basic CPU types without company name.
# Some are omitted here because they have special meanings below.
tahoe | i860 | m32r | m68k | m68000 | m88k | ns32k | arc | arm \
| arme[lb] | pyramid | mn10200 | mn10300 | tron | a29k \
| 580 | i960 | h8300 | hppa | hppa1.0 | hppa1.1 | hppa2.0 \
| alpha | alphaev5 | alphaev56 | we32k | ns16k | clipper \
| i370 | sh | powerpc | powerpcle | 1750a | dsp16xx | pdp11 \
| mips64 | mipsel | mips64el | mips64orion | mips64orionel \
| mipstx39 | mipstx39el \
| sparc | sparclet | sparclite | sparc64 | v850)
basic_machine=$basic_machine-unknown
;;
# We use `pc' rather than `unknown'
# because (1) that's what they normally are, and
# (2) the word "unknown" tends to confuse beginning users.
i[34567]86)
basic_machine=$basic_machine-pc
;;
# Object if more than one company name word.
*-*-*)
echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
exit 1
;;
# Recognize the basic CPU types with company name.
vax-* | tahoe-* | i[34567]86-* | i860-* | m32r-* | m68k-* | m68000-* \
| m88k-* | sparc-* | ns32k-* | fx80-* | arc-* | arm-* | c[123]* \
| mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \
| power-* | none-* | 580-* | cray2-* | h8300-* | i960-* \
| xmp-* | ymp-* | hppa-* | hppa1.0-* | hppa1.1-* | hppa2.0-* \
| alpha-* | alphaev5-* | alphaev56-* | we32k-* | cydra-* \
| ns16k-* | pn-* | np1-* | xps100-* | clipper-* | orion-* \
| sparclite-* | pdp11-* | sh-* | powerpc-* | powerpcle-* \
| sparc64-* | mips64-* | mipsel-* \
| mips64el-* | mips64orion-* | mips64orionel-* \
| mipstx39-* | mipstx39el-* \
| f301-*)
;;
# Recognize the various machine names and aliases which stand
# for a CPU type and a company and sometimes even an OS.
3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)
basic_machine=m68000-att
;;
3b*)
basic_machine=we32k-att
;;
alliant | fx80)
basic_machine=fx80-alliant
;;
altos | altos3068)
basic_machine=m68k-altos
;;
am29k)
basic_machine=a29k-none
os=-bsd
;;
amdahl)
basic_machine=580-amdahl
os=-sysv
;;
amiga | amiga-*)
basic_machine=m68k-cbm
;;
amigaos | amigados)
basic_machine=m68k-cbm
os=-amigaos
;;
amigaunix | amix)
basic_machine=m68k-cbm
os=-sysv4
;;
apollo68)
basic_machine=m68k-apollo
os=-sysv
;;
aux)
basic_machine=m68k-apple
os=-aux
;;
balance)
basic_machine=ns32k-sequent
os=-dynix
;;
convex-c1)
basic_machine=c1-convex
os=-bsd
;;
convex-c2)
basic_machine=c2-convex
os=-bsd
;;
convex-c32)
basic_machine=c32-convex
os=-bsd
;;
convex-c34)
basic_machine=c34-convex
os=-bsd
;;
convex-c38)
basic_machine=c38-convex
os=-bsd
;;
cray | ymp)
basic_machine=ymp-cray
os=-unicos
;;
cray2)
basic_machine=cray2-cray
os=-unicos
;;
[ctj]90-cray)
basic_machine=c90-cray
os=-unicos
;;
crds | unos)
basic_machine=m68k-crds
;;
da30 | da30-*)
basic_machine=m68k-da30
;;
decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)
basic_machine=mips-dec
;;
delta | 3300 | motorola-3300 | motorola-delta \
| 3300-motorola | delta-motorola)
basic_machine=m68k-motorola
;;
delta88)
basic_machine=m88k-motorola
os=-sysv3
;;
dpx20 | dpx20-*)
basic_machine=rs6000-bull
os=-bosx
;;
dpx2* | dpx2*-bull)
basic_machine=m68k-bull
os=-sysv3
;;
ebmon29k)
basic_machine=a29k-amd
os=-ebmon
;;
elxsi)
basic_machine=elxsi-elxsi
os=-bsd
;;
encore | umax | mmax)
basic_machine=ns32k-encore
;;
fx2800)
basic_machine=i860-alliant
;;
genix)
basic_machine=ns32k-ns
;;
gmicro)
basic_machine=tron-gmicro
os=-sysv
;;
h3050r* | hiux*)
basic_machine=hppa1.1-hitachi
os=-hiuxwe2
;;
h8300hms)
basic_machine=h8300-hitachi
os=-hms
;;
harris)
basic_machine=m88k-harris
os=-sysv3
;;
hp300-*)
basic_machine=m68k-hp
;;
hp300bsd)
basic_machine=m68k-hp
os=-bsd
;;
hp300hpux)
basic_machine=m68k-hp
os=-hpux
;;
hp9k2[0-9][0-9] | hp9k31[0-9])
basic_machine=m68000-hp
;;
hp9k3[2-9][0-9])
basic_machine=m68k-hp
;;
hp9k7[0-9][0-9] | hp7[0-9][0-9] | hp9k8[0-9]7 | hp8[0-9]7)
basic_machine=hppa1.1-hp
;;
hp9k8[0-9][0-9] | hp8[0-9][0-9])
basic_machine=hppa1.0-hp
;;
hppa-next)
os=-nextstep3
;;
i370-ibm* | ibm*)
basic_machine=i370-ibm
os=-mvs
;;
# I'm not sure what "Sysv32" means. Should this be sysv3.2?
i[34567]86v32)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv32
;;
i[34567]86v4*)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv4
;;
i[34567]86v)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-sysv
;;
i[34567]86sol2)
basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'`
os=-solaris2
;;
iris | iris4d)
basic_machine=mips-sgi
case $os in
-irix*)
;;
*)
os=-irix4
;;
esac
;;
isi68 | isi)
basic_machine=m68k-isi
os=-sysv
;;
m88k-omron*)
basic_machine=m88k-omron
;;
magnum | m3230)
basic_machine=mips-mips
os=-sysv
;;
merlin)
basic_machine=ns32k-utek
os=-sysv
;;
miniframe)
basic_machine=m68000-convergent
;;
mipsel*-linux*)
basic_machine=mipsel-unknown
os=-linux-gnu
;;
mips*-linux*)
basic_machine=mips-unknown
os=-linux-gnu
;;
mips3*-*)
basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
;;
mips3*)
basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
;;
ncr3000)
basic_machine=i486-ncr
os=-sysv4
;;
news | news700 | news800 | news900)
basic_machine=m68k-sony
os=-newsos
;;
news1000)
basic_machine=m68030-sony
os=-newsos
;;
news-3600 | risc-news)
basic_machine=mips-sony
os=-newsos
;;
next | m*-next )
basic_machine=m68k-next
case $os in
-nextstep* )
;;
-ns2*)
os=-nextstep2
;;
*)
os=-nextstep3
;;
esac
;;
nh3000)
basic_machine=m68k-harris
os=-cxux
;;
nh[45]000)
basic_machine=m88k-harris
os=-cxux
;;
nindy960)
basic_machine=i960-intel
os=-nindy
;;
np1)
basic_machine=np1-gould
;;
pa-hitachi)
basic_machine=hppa1.1-hitachi
os=-hiuxwe2
;;
paragon)
basic_machine=i860-intel
os=-osf
;;
pbd)
basic_machine=sparc-tti
;;
pbb)
basic_machine=m68k-tti
;;
pc532 | pc532-*)
basic_machine=ns32k-pc532
;;
pentium | p5 | k5 | nexen)
basic_machine=i586-pc
;;
pentiumpro | p6 | k6 | 6x86)
basic_machine=i686-pc
;;
pentiumii | pentium2)
basic_machine=i786-pc
;;
pentium-* | p5-* | k5-* | nexen-*)
basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pentiumpro-* | p6-* | k6-* | 6x86-*)
basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pentiumii-* | pentium2-*)
basic_machine=i786-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
pn)
basic_machine=pn-gould
;;
power) basic_machine=rs6000-ibm
;;
ppc) basic_machine=powerpc-unknown
;;
ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
ppcle | powerpclittle | ppc-le | powerpc-little)
basic_machine=powerpcle-unknown
;;
ppcle-* | powerpclittle-*)
basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'`
;;
ps2)
basic_machine=i386-ibm
;;
rm[46]00)
basic_machine=mips-siemens
;;
rtpc | rtpc-*)
basic_machine=romp-ibm
;;
sequent)
basic_machine=i386-sequent
;;
sh)
basic_machine=sh-hitachi
os=-hms
;;
sps7)
basic_machine=m68k-bull
os=-sysv2
;;
spur)
basic_machine=spur-unknown
;;
sun2)
basic_machine=m68000-sun
;;
sun2os3)
basic_machine=m68000-sun
os=-sunos3
;;
sun2os4)
basic_machine=m68000-sun
os=-sunos4
;;
sun3os3)
basic_machine=m68k-sun
os=-sunos3
;;
sun3os4)
basic_machine=m68k-sun
os=-sunos4
;;
sun4os3)
basic_machine=sparc-sun
os=-sunos3
;;
sun4os4)
basic_machine=sparc-sun
os=-sunos4
;;
sun4sol2)
basic_machine=sparc-sun
os=-solaris2
;;
sun3 | sun3-*)
basic_machine=m68k-sun
;;
sun4)
basic_machine=sparc-sun
;;
sun386 | sun386i | roadrunner)
basic_machine=i386-sun
;;
symmetry)
basic_machine=i386-sequent
os=-dynix
;;
tx39)
basic_machine=mipstx39-unknown
;;
tx39el)
basic_machine=mipstx39el-unknown
;;
tower | tower-32)
basic_machine=m68k-ncr
;;
udi29k)
basic_machine=a29k-amd
os=-udi
;;
ultra3)
basic_machine=a29k-nyu
os=-sym1
;;
vaxv)
basic_machine=vax-dec
os=-sysv
;;
vms)
basic_machine=vax-dec
os=-vms
;;
vpp*|vx|vx-*)
basic_machine=f301-fujitsu
;;
vxworks960)
basic_machine=i960-wrs
os=-vxworks
;;
vxworks68)
basic_machine=m68k-wrs
os=-vxworks
;;
vxworks29k)
basic_machine=a29k-wrs
os=-vxworks
;;
xmp)
basic_machine=xmp-cray
os=-unicos
;;
xps | xps100)
basic_machine=xps100-honeywell
;;
none)
basic_machine=none-none
os=-none
;;
# Here we handle the default manufacturer of certain CPU types. It is in
# some cases the only manufacturer, in others, it is the most popular.
mips)
if [ x$os = x-linux-gnu ]; then
basic_machine=mips-unknown
else
basic_machine=mips-mips
fi
;;
romp)
basic_machine=romp-ibm
;;
rs6000)
basic_machine=rs6000-ibm
;;
vax)
basic_machine=vax-dec
;;
pdp11)
basic_machine=pdp11-dec
;;
we32k)
basic_machine=we32k-att
;;
sparc)
basic_machine=sparc-sun
;;
cydra)
basic_machine=cydra-cydrome
;;
orion)
basic_machine=orion-highlevel
;;
orion105)
basic_machine=clipper-highlevel
;;
*)
echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
exit 1
;;
esac
# Here we canonicalize certain aliases for manufacturers.
case $basic_machine in
*-digital*)
basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`
;;
*-commodore*)
basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`
;;
*)
;;
esac
# Decode manufacturer-specific aliases for certain operating systems.
if [ x"$os" != x"" ]
then
case $os in
# First match some system type aliases
# that might get confused with valid system types.
# -solaris* is a basic system type, with this one exception.
-solaris1 | -solaris1.*)
os=`echo $os | sed -e 's|solaris1|sunos4|'`
;;
-solaris)
os=-solaris2
;;
-svr4*)
os=-sysv4
;;
-unixware*)
os=-sysv4.2uw
;;
-gnu/linux*)
os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'`
;;
# First accept the basic system types.
# The portable systems comes first.
# Each alternative MUST END IN A *, to match a version number.
# -sysv* is not here because it comes later, after sysvr4.
-gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
| -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\
| -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \
| -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \
| -aos* \
| -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \
| -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \
| -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \
| -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \
| -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \
| -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \
| -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \
| -mingw32* | -linux-gnu* | -uxpv* | -beos* | -windows*)
# LVM: added windows
# Remember, each alternative MUST END IN *, to match a version number.
;;
-linux*)
os=`echo $os | sed -e 's|linux|linux-gnu|'`
;;
-sunos5*)
os=`echo $os | sed -e 's|sunos5|solaris2|'`
;;
-sunos6*)
os=`echo $os | sed -e 's|sunos6|solaris3|'`
;;
-osfrose*)
os=-osfrose
;;
-osf*)
os=-osf
;;
-utek*)
os=-bsd
;;
-dynix*)
os=-bsd
;;
-acis*)
os=-aos
;;
-ctix* | -uts*)
os=-sysv
;;
-ns2 )
os=-nextstep2
;;
# Preserve the version number of sinix5.
-sinix5.*)
os=`echo $os | sed -e 's|sinix|sysv|'`
;;
-sinix*)
os=-sysv4
;;
-triton*)
os=-sysv3
;;
-oss*)
os=-sysv3
;;
-svr4)
os=-sysv4
;;
-svr3)
os=-sysv3
;;
-sysvr4)
os=-sysv4
;;
# This must come after -sysvr4.
-sysv*)
;;
-xenix)
os=-xenix
;;
-macosx*)
os=-macosx
;;
-none)
;;
*)
# Get rid of the `-' at the beginning of $os.
os=`echo $os | sed 's/[^-]*-//'`
echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2
exit 1
;;
esac
else
# Here we handle the default operating systems that come with various machines.
# The value should be what the vendor currently ships out the door with their
# machine or put another way, the most popular os provided with the machine.
# Note that if you're going to try to match "-MANUFACTURER" here (say,
# "-sun"), then you have to tell the case statement up towards the top
# that MANUFACTURER isn't an operating system. Otherwise, code above
# will signal an error saying that MANUFACTURER isn't an operating
# system, and we'll never get to this point.
case $basic_machine in
*-acorn)
os=-riscix1.2
;;
arm*-semi)
os=-aout
;;
pdp11-*)
os=-none
;;
*-dec | vax-*)
os=-ultrix4.2
;;
m68*-apollo)
os=-domain
;;
i386-sun)
os=-sunos4.0.2
;;
m68000-sun)
os=-sunos3
# This also exists in the configure program, but was not the
# default.
# os=-sunos4
;;
*-tti) # must be before sparc entry or we get the wrong os.
...
[truncated message content] |
|
From: <kr_...@us...> - 2003-09-05 11:38:00
|
Update of /cvsroot/htoolkit/HSQL/src/MySQL In directory sc8-pr-cvs1:/tmp/cvs-serv12029/src/MySQL Modified Files: HSQL.hsc Log Message: Basic build system for HSQL Index: HSQL.hsc =================================================================== RCS file: /cvsroot/htoolkit/HSQL/src/MySQL/HSQL.hsc,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** HSQL.hsc 24 Jan 2003 00:08:58 -0000 1.1 --- HSQL.hsc 5 Sep 2003 11:37:55 -0000 1.2 *************** *** 21,27 **** , forEachRow' -- :: (Statement -> IO ()) -> Statement -> IO () , collectRows -- :: (Statement -> IO s) -> Statement -> IO [s] - #ifdef ENABLED_GUI - , fillitems -- :: HasItems w => Connection -> String -> Config (w Int) - #endif ) where --- 21,24 ---- *************** *** 389,405 **** return (x:xs) else closeStatement stmt >> return [] - - - ----------------------------------------------------------------------------------------- - -- fillitems - ----------------------------------------------------------------------------------------- - - #ifdef ENABLED_GUI - fillitems :: HasItems w => Connection -> String -> Config (w Int) - fillitems conn sqlExpr widget = query conn sqlExpr >>= forEachRow' addItemToWidget - where - addItemToWidget stmt = do - (id :: Int) <- getFieldValue stmt "id" - (title :: Title) <- getFieldValue stmt "Name" - addItem id title widget - #endif \ No newline at end of file --- 386,387 ---- |
221 messages has been excluded from this view by a project administrator.
