From a7afae250d4de6f18fe9e98e4ae5621e0d793477 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 1 Jun 2008 00:48:38 -0500 Subject: [PATCH 001/354] clean up code some make \# retries user configurable --- extra/db/db.factor | 4 ++-- extra/db/queries/queries.factor | 10 +++++----- extra/db/sql/sql.factor | 4 +++- extra/db/tuples/tuples.factor | 14 ++++++++------ 4 files changed, 18 insertions(+), 14 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 8d1feca6c7..889eff196c 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -35,7 +35,7 @@ HOOK: db-close db ( handle -- ) handle>> db-close ] with-variable ; -TUPLE: statement handle sql in-params out-params bind-params bound? type ; +TUPLE: statement handle sql in-params out-params bind-params bound? type retries ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; @@ -89,7 +89,7 @@ M: object execute-statement* ( statement type -- ) swap >>out-params swap >>in-params swap >>sql ; - + : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 59ee60aa1f..d524080e57 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math namespaces sequences random strings math.parser math.intervals combinators -math.bitfields.lib namespaces.lib db db.tuples db.types ; +math.bitfields.lib namespaces.lib db db.tuples db.types +sequences.lib ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -99,16 +100,15 @@ M: string where ( spec obj -- ) object-where ; ] with filter ; : where-clause ( tuple specs -- ) - dupd filter-slots - dup empty? [ - 2drop + dupd filter-slots [ + drop ] [ " where " 0% [ " and " 0% ] [ 2dup slot-name>> swap get-slot-named where ] interleave drop - ] if ; + ] if-empty ; M: db ( tuple table -- sql ) [ diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index 82c6e370bd..756aeea7c0 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -5,7 +5,9 @@ IN: db.sql SYMBOLS: insert update delete select distinct columns from as where group-by having order-by limit offset is-null desc all -any count avg table values ; +any count avg table values ? ; + +! Output an s-exp sql statement and an alist of keys/values : input-spec, 1, ; : output-spec, 2, ; diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index bac141d6d2..b7bf6a7fbe 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -55,6 +55,7 @@ SINGLETON: retryable [ make-retryable ] map ] [ retryable >>type + 10 >>retries ] if ; : regenerate-params ( statement -- statement ) @@ -69,12 +70,13 @@ SINGLETON: retryable ] 2map >>bind-params ; M: retryable execute-statement* ( statement type -- ) - drop - [ - [ query-results dispose t ] - [ ] - [ regenerate-params bind-statement* f ] cleanup - ] curry 10 retry drop ; + drop [ + [ + [ query-results dispose t ] + [ ] + [ regenerate-params bind-statement* f ] cleanup + ] curry + ] [ retries>> ] bi retry drop ; : resulting-tuple ( class row out-params -- tuple ) rot class new [ From 96ce30a534f744cc160b1075bd92de6525805f9d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 1 Jun 2008 11:25:09 -0500 Subject: [PATCH 002/354] add advanced-select word --- extra/db/tuples/tuples.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index b7bf6a7fbe..09fd63b233 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -154,3 +154,7 @@ M: retryable execute-statement* ( statement type -- ) : select-tuple ( tuple -- tuple/f ) dup dup class f f f 1 do-select ?first ; + +: advanced-select ( tuple groups order offset limit -- tuples ) + >r >r >r >r dup dup class r> r> r> r> + do-select ; From b974133285990ffb7ffc9e427c3503bc08b42281 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Tue, 3 Jun 2008 11:01:04 +1200 Subject: [PATCH 003/354] Re-add jni library to unmaintained --- unmaintained/jni/jni-internals.factor | 357 ++++++++++++++++++++++++++ unmaintained/jni/jni.factor | 22 ++ unmaintained/jni/load.factor | 4 + 3 files changed, 383 insertions(+) create mode 100644 unmaintained/jni/jni-internals.factor create mode 100644 unmaintained/jni/jni.factor create mode 100644 unmaintained/jni/load.factor diff --git a/unmaintained/jni/jni-internals.factor b/unmaintained/jni/jni-internals.factor new file mode 100644 index 0000000000..49bc57b108 --- /dev/null +++ b/unmaintained/jni/jni-internals.factor @@ -0,0 +1,357 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +IN: jni-internals +USING: kernel alien arrays sequences ; + +LIBRARY: jvm + +TYPEDEF: int jint +TYPEDEF: uchar jboolean +TYPEDEF: void* JNIEnv + +C-STRUCT: jdk-init-args + { "jint" "version" } + { "void*" "properties" } + { "jint" "check-source" } + { "jint" "native-stack-size" } + { "jint" "java-stack-size" } + { "jint" "min-heap-size" } + { "jint" "max-heap-size" } + { "jint" "verify-mode" } + { "char*" "classpath" } + { "void*" "vprintf" } + { "void*" "exit" } + { "void*" "abort" } + { "jint" "enable-class-gc" } + { "jint" "enable-verbose-gc" } + { "jint" "disable-async-gc" } + { "jint" "verbose" } + { "jboolean" "debugging" } + { "jint" "debug-port" } ; + +C-STRUCT: JNIInvokeInterface + { "void*" "reserved0" } + { "void*" "reserved1" } + { "void*" "reserved2" } + { "void*" "DestroyJavaVM" } + { "void*" "AttachCurrentThread" } + { "void*" "DetachCurrentThread" } + { "void*" "GetEnv" } + { "void*" "AttachCurrentThreadAsDaemon" } ; + +C-STRUCT: JavaVM + { "JNIInvokeInterface*" "functions" } ; + +C-STRUCT: JNINativeInterface + { "void*" "reserved0" } + { "void*" "reserved1" } + { "void*" "reserved2" } + { "void*" "reserved3" } + { "void*" "GetVersion" } + { "void*" "DefineClass" } + { "void*" "FindClass" } + { "void*" "FromReflectedMethod" } + { "void*" "FromReflectedField" } + { "void*" "ToReflectedMethod" } + { "void*" "GetSuperclass" } + { "void*" "IsAssignableFrom" } + { "void*" "ToReflectedField" } + { "void*" "Throw" } + { "void*" "ThrowNew" } + { "void*" "ExceptionOccurred" } + { "void*" "ExceptionDescribe" } + { "void*" "ExceptionClear" } + { "void*" "FatalError" } + { "void*" "PushLocalFrame" } + { "void*" "PopLocalFrame" } + { "void*" "NewGlobalRef" } + { "void*" "DeleteGlobalRef" } + { "void*" "DeleteLocalRef" } + { "void*" "IsSameObject" } + { "void*" "NewLocalRef" } + { "void*" "EnsureLocalCapacity" } + { "void*" "AllocObject" } + { "void*" "NewObject" } + { "void*" "NewObjectV" } + { "void*" "NewObjectA" } + { "void*" "GetObjectClass" } + { "void*" "IsInstanceOf" } + { "void*" "GetMethodID" } + { "void*" "CallObjectMethod" } + { "void*" "CallObjectMethodV" } + { "void*" "CallObjectMethodA" } + { "void*" "CallBooleanMethod" } + { "void*" "CallBooleanMethodV" } + { "void*" "CallBooleanMethodA" } + { "void*" "CallByteMethod" } + { "void*" "CallByteMethodV" } + { "void*" "CallByteMethodA" } + { "void*" "CallCharMethod" } + { "void*" "CallCharMethodV" } + { "void*" "CallCharMethodA" } + { "void*" "CallShortMethod" } + { "void*" "CallShortMethodV" } + { "void*" "CallShortMethodA" } + { "void*" "CallIntMethod" } + { "void*" "CallIntMethodV" } + { "void*" "CallIntMethodA" } + { "void*" "CallLongMethod" } + { "void*" "CallLongMethodV" } + { "void*" "CallLongMethodA" } + { "void*" "CallFloatMethod" } + { "void*" "CallFloatMethodV" } + { "void*" "CallFloatMethodA" } + { "void*" "CallDoubleMethod" } + { "void*" "CallDoubleMethodV" } + { "void*" "CallDoubleMethodA" } + { "void*" "CallVoidMethod" } + { "void*" "CallVoidMethodV" } + { "void*" "CallVoidMethodA" } + { "void*" "CallNonvirtualObjectMethod" } + { "void*" "CallNonvirtualObjectMethodV" } + { "void*" "CallNonvirtualObjectMethodA" } + { "void*" "CallNonvirtualBooleanMethod" } + { "void*" "CallNonvirtualBooleanMethodV" } + { "void*" "CallNonvirtualBooleanMethodA" } + { "void*" "CallNonvirtualByteMethod" } + { "void*" "CallNonvirtualByteMethodV" } + { "void*" "CallNonvirtualByteMethodA" } + { "void*" "CallNonvirtualCharMethod" } + { "void*" "CallNonvirtualCharMethodV" } + { "void*" "CallNonvirtualCharMethodA" } + { "void*" "CallNonvirtualShortMethod" } + { "void*" "CallNonvirtualShortMethodV" } + { "void*" "CallNonvirtualShortMethodA" } + { "void*" "CallNonvirtualIntMethod" } + { "void*" "CallNonvirtualIntMethodV" } + { "void*" "CallNonvirtualIntMethodA" } + { "void*" "CallNonvirtualLongMethod" } + { "void*" "CallNonvirtualLongMethodV" } + { "void*" "CallNonvirtualLongMethodA" } + { "void*" "CallNonvirtualFloatMethod" } + { "void*" "CallNonvirtualFloatMethodV" } + { "void*" "CallNonvirtualFloatMethodA" } + { "void*" "CallNonvirtualDoubleMethod" } + { "void*" "CallNonvirtualDoubleMethodV" } + { "void*" "CallNonvirtualDoubleMethodA" } + { "void*" "CallNonvirtualVoidMethod" } + { "void*" "CallNonvirtualVoidMethodV" } + { "void*" "CallNonvirtualVoidMethodA" } + { "void*" "GetFieldID" } + { "void*" "GetObjectField" } + { "void*" "GetBooleanField" } + { "void*" "GetByteField" } + { "void*" "GetCharField" } + { "void*" "GetShortField" } + { "void*" "GetIntField" } + { "void*" "GetLongField" } + { "void*" "GetFloatField" } + { "void*" "GetDoubleField" } + { "void*" "SetObjectField" } + { "void*" "SetBooleanField" } + { "void*" "SetByteField" } + { "void*" "SetCharField" } + { "void*" "SetShortField" } + { "void*" "SetIntField" } + { "void*" "SetLongField" } + { "void*" "SetFloatField" } + { "void*" "SetDoubleField" } + { "void*" "GetStaticMethodID" } + { "void*" "CallStaticObjectMethod" } + { "void*" "CallStaticObjectMethodV" } + { "void*" "CallStaticObjectMethodA" } + { "void*" "CallStaticBooleanMethod" } + { "void*" "CallStaticBooleanMethodV" } + { "void*" "CallStaticBooleanMethodA" } + { "void*" "CallStaticByteMethod" } + { "void*" "CallStaticByteMethodV" } + { "void*" "CallStaticByteMethodA" } + { "void*" "CallStaticCharMethod" } + { "void*" "CallStaticCharMethodV" } + { "void*" "CallStaticCharMethodA" } + { "void*" "CallStaticShortMethod" } + { "void*" "CallStaticShortMethodV" } + { "void*" "CallStaticShortMethodA" } + { "void*" "CallStaticIntMethod" } + { "void*" "CallStaticIntMethodV" } + { "void*" "CallStaticIntMethodA" } + { "void*" "CallStaticLongMethod" } + { "void*" "CallStaticLongMethodV" } + { "void*" "CallStaticLongMethodA" } + { "void*" "CallStaticFloatMethod" } + { "void*" "CallStaticFloatMethodV" } + { "void*" "CallStaticFloatMethodA" } + { "void*" "CallStaticDoubleMethod" } + { "void*" "CallStaticDoubleMethodV" } + { "void*" "CallStaticDoubleMethodA" } + { "void*" "CallStaticVoidMethod" } + { "void*" "CallStaticVoidMethodV" } + { "void*" "CallStaticVoidMethodA" } + { "void*" "GetStaticFieldID" } + { "void*" "GetStaticObjectField" } + { "void*" "GetStaticBooleanField" } + { "void*" "GetStaticByteField" } + { "void*" "GetStaticCharField" } + { "void*" "GetStaticShortField" } + { "void*" "GetStaticIntField" } + { "void*" "GetStaticLongField" } + { "void*" "GetStaticFloatField" } + { "void*" "GetStaticDoubleField" } + { "void*" "SetStaticObjectField" } + { "void*" "SetStaticBooleanField" } + { "void*" "SetStaticByteField" } + { "void*" "SetStaticCharField" } + { "void*" "SetStaticShortField" } + { "void*" "SetStaticIntField" } + { "void*" "SetStaticLongField" } + { "void*" "SetStaticFloatField" } + { "void*" "SetStaticDoubleField" } + { "void*" "NewString" } + { "void*" "GetStringLength" } + { "void*" "GetStringChars" } + { "void*" "ReleaseStringChars" } + { "void*" "NewStringUTF" } + { "void*" "GetStringUTFLength" } + { "void*" "GetStringUTFChars" } + { "void*" "ReleaseStringUTFChars" } + { "void*" "GetArrayLength" } + { "void*" "NewObjectArray" } + { "void*" "GetObjectArrayElement" } + { "void*" "SetObjectArrayElement" } + { "void*" "NewBooleanArray" } + { "void*" "NewByteArray" } + { "void*" "NewCharArray" } + { "void*" "NewShortArray" } + { "void*" "NewIntArray" } + { "void*" "NewLongArray" } + { "void*" "NewFloatArray" } + { "void*" "NewDoubleArray" } + { "void*" "GetBooleanArrayElements" } + { "void*" "GetByteArrayElements" } + { "void*" "GetCharArrayElements" } + { "void*" "GetShortArrayElements" } + { "void*" "GetIntArrayElements" } + { "void*" "GetLongArrayElements" } + { "void*" "GetFloatArrayElements" } + { "void*" "GetDoubleArrayElements" } + { "void*" "ReleaseBooleanArrayElements" } + { "void*" "ReleaseByteArrayElements" } + { "void*" "ReleaseCharArrayElements" } + { "void*" "ReleaseShortArrayElements" } + { "void*" "ReleaseIntArrayElements" } + { "void*" "ReleaseLongArrayElements" } + { "void*" "ReleaseFloatArrayElements" } + { "void*" "ReleaseDoubleArrayElements" } + { "void*" "GetBooleanArrayRegion" } + { "void*" "GetByteArrayRegion" } + { "void*" "GetCharArrayRegion" } + { "void*" "GetShortArrayRegion" } + { "void*" "GetIntArrayRegion" } + { "void*" "GetLongArrayRegion" } + { "void*" "GetFloatArrayRegion" } + { "void*" "GetDoubleArrayRegion" } + { "void*" "SetBooleanArrayRegion" } + { "void*" "SetByteArrayRegion" } + { "void*" "SetCharArrayRegion" } + { "void*" "SetShortArrayRegion" } + { "void*" "SetIntArrayRegion" } + { "void*" "SetLongArrayRegion" } + { "void*" "SetFloatArrayRegion" } + { "void*" "SetDoubleArrayRegion" } + { "void*" "RegisterNatives" } + { "void*" "UnregisterNatives" } + { "void*" "MonitorEnter" } + { "void*" "MonitorExit" } + { "void*" "GetJavaVM" } + { "void*" "GetStringRegion" } + { "void*" "GetStringUTFRegion" } + { "void*" "GetPrimitiveArrayCritical" } + { "void*" "ReleasePrimitiveArrayCritical" } + { "void*" "GetStringCritical" } + { "void*" "ReleaseStringCritical" } + { "void*" "NewWeakGlobalRef" } + { "void*" "DeleteWeakGlobalRef" } + { "void*" "ExceptionCheck" } + { "void*" "NewDirectByteBuffer" } + { "void*" "GetDirectBufferAddress" } + { "void*" "GetDirectBufferCapacity" } ; + +C-STRUCT: JNIEnv + { "JNINativeInterface*" "functions" } ; + +FUNCTION: jint JNI_GetDefaultJavaVMInitArgs ( jdk-init-args* args ) ; +FUNCTION: jint JNI_CreateJavaVM ( void** pvm, void** penv, void* args ) ; + +: ( -- jdk-init-args ) + "jdk-init-args" HEX: 00010004 over set-jdk-init-args-version ; + +: jni1 ( -- init-args int ) + dup JNI_GetDefaultJavaVMInitArgs ; + +: jni2 ( -- vm env int ) + f f [ + jni1 drop JNI_CreateJavaVM + ] 2keep rot dup 0 = [ + >r >r 0 swap void*-nth r> 0 swap void*-nth r> + ] when ; + +: (destroy-java-vm) + "int" { "void*" } "cdecl" alien-indirect ; + +: (attach-current-thread) + "int" { "void*" "void*" "void*" } "cdecl" alien-indirect ; + +: (detach-current-thread) + "int" { "void*" } "cdecl" alien-indirect ; + +: (get-env) + "int" { "void*" "void*" "int" } "cdecl" alien-indirect ; + +: (attach-current-thread-as-daemon) + "int" { "void*" "void*" "void*" } "cdecl" alien-indirect ; + +: destroy-java-vm ( javavm -- int ) + dup JavaVM-functions JNIInvokeInterface-DestroyJavaVM (destroy-java-vm) ; + +: (get-version) + "jint" { "JNIEnv*" } "cdecl" alien-indirect ; + +: get-version ( jnienv -- int ) + dup JNIEnv-functions JNINativeInterface-GetVersion (get-version) ; + +: (find-class) + "void*" { "JNINativeInterface*" "char*" } "cdecl" alien-indirect ; + +: find-class ( name jnienv -- int ) + dup swapd JNIEnv-functions JNINativeInterface-FindClass (find-class) ; + +: (get-static-field-id) + "void*" { "JNINativeInterface*" "void*" "char*" "char*" } "cdecl" alien-indirect ; + +: get-static-field-id ( class name sig jnienv -- int ) + dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-GetStaticFieldID (get-static-field-id) ; + +: (get-static-object-field) + "void*" { "JNINativeInterface*" "void*" "void*" } "cdecl" alien-indirect ; + +: get-static-object-field ( class id jnienv -- int ) + dup >r >r 2array r> swap first2 r> JNIEnv-functions JNINativeInterface-GetStaticObjectField (get-static-object-field) ; + +: (get-method-id) + "void*" { "JNINativeInterface*" "void*" "char*" "char*" } "cdecl" alien-indirect ; + +: get-method-id ( class name sig jnienv -- int ) + dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-GetMethodID (get-method-id) ; + +: (new-string) + "void*" { "JNINativeInterface*" "char*" "int" } "cdecl" alien-indirect ; + +: new-string ( str jnienv -- str ) + dup >r >r dup length 2array r> swap first2 r> JNIEnv-functions JNINativeInterface-NewString (new-string) ; + +: (call1) + "void" { "JNINativeInterface*" "void*" "void*" "int" } "cdecl" alien-indirect ; + +: call1 ( obj method-id jstr jnienv -- ) + dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-CallObjectMethod (call1) ; + diff --git a/unmaintained/jni/jni.factor b/unmaintained/jni/jni.factor new file mode 100644 index 0000000000..86e1670c50 --- /dev/null +++ b/unmaintained/jni/jni.factor @@ -0,0 +1,22 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +IN: jni +USING: kernel jni-internals namespaces ; + +! High level interface for JNI to be added here... + +: test0 ( -- ) + jni2 drop nip "env" set ; + +: test1 ( -- system ) + "java/lang/System" "env" get find-class ; + +: test2 ( system -- system.out ) + dup "out" "Ljava/io/PrintStream;" "env" get get-static-field-id + "env" get get-static-object-field ; + +: test3 ( int system.out -- ) + "java/io/PrintStream" "env" get find-class ! jstr out class + "println" "(I)V" "env" get get-method-id ! jstr out id + rot "env" get call1 ; + \ No newline at end of file diff --git a/unmaintained/jni/load.factor b/unmaintained/jni/load.factor new file mode 100644 index 0000000000..f5fd45c8d9 --- /dev/null +++ b/unmaintained/jni/load.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2006 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +PROVIDE: libs/jni +{ +files+ { "jni-internals.factor" "jni.factor" } } ; From 95663e56ce0c57cf7ee7ccb2a67e823e66b4f135 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 7 Jun 2008 10:48:05 -0500 Subject: [PATCH 004/354] commit local changes --- extra/db/queries/queries.factor | 47 ++++++++++++++++++++++++++--- extra/db/sql/sql.factor | 32 ++++++++++++-------- extra/db/tuples/tuples-tests.factor | 6 ++-- extra/db/tuples/tuples.factor | 22 +++++++++++--- 4 files changed, 82 insertions(+), 25 deletions(-) diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index d524080e57..29abe9bddc 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -3,7 +3,7 @@ USING: accessors kernel math namespaces sequences random strings math.parser math.intervals combinators math.bitfields.lib namespaces.lib db db.tuples db.types -sequences.lib ; +sequences.lib db.sql classes words shuffle arrays ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -146,7 +146,7 @@ M: db ( tuple class -- statement ) number>string " limit " prepend append ] curry change-sql drop ; -: make-advanced-statement ( tuple advanced -- tuple' ) +: make-query ( tuple query -- tuple' ) dupd { [ group>> [ do-group ] [ drop ] if* ] @@ -155,6 +155,43 @@ M: db ( tuple class -- statement ) [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; -M: db ( tuple class group order limit offset -- tuple ) - advanced-statement boa - [ ] dip make-advanced-statement ; +M: db ( tuple class group order limit offset -- tuple ) + \ query boa + [ ] dip make-query ; + +! select ID, NAME, SCORE from EXAM limit 1 offset 3 + +: select-tuples* ( tuple -- statement ) + dup + [ + select 0, + dup class db-columns [ ", " 0, ] + [ dup column-name>> 0, 2, ] interleave + from 0, + class word-name 0, + ] { { } { } { } } nmake + >r >r parse-sql 4drop r> r> + maybe-make-retryable do-select ; + +M: db ( tuple class groups -- statement ) + f f f \ query boa + [ [ "select count(*) from " 0% 0% where-clause ] query-make ] + dip make-query ; + +: where-clause* ( tuple specs -- ) + dupd filter-slots [ + drop + ] [ + \ where 0, + [ 2dup slot-name>> swap get-slot-named where ] map 2array 0, + drop + ] if-empty ; + +: delete-tuple* ( tuple -- sql ) + dup + [ + delete 0, from 0, dup class db-table 0, + dup class db-columns where-clause* + ] { { } { } { } } nmake + >r >r parse-sql 4drop r> r> + maybe-make-retryable do-select ; diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index 756aeea7c0..dc8b5d1fb1 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -5,7 +5,7 @@ IN: db.sql SYMBOLS: insert update delete select distinct columns from as where group-by having order-by limit offset is-null desc all -any count avg table values ? ; +any count avg table values ; ! Output an s-exp sql statement and an alist of keys/values @@ -25,12 +25,27 @@ DEFER: sql% : sql-function, ( seq function -- ) sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; +: sql-where ( seq -- ) +B + [ + [ second 0, ] + [ first 0, ] + [ third 1, \ ? 0, ] tri + ] each ; + : sql-array% ( array -- ) +B unclip { + { \ create [ "create table" sql% ] } + { \ drop [ "drop table" sql% ] } + { \ insert [ "insert into" sql% ] } + { \ update [ "update" sql% ] } + { \ delete [ "delete" sql% ] } + { \ select [ B "select" sql% "," (sql-interleave) ] } { \ columns [ "," (sql-interleave) ] } { \ from [ "from" "," sql-interleave ] } - { \ where [ "where" "and" sql-interleave ] } + { \ where [ B "where" 0, sql-where ] } { \ group-by [ "group by" "," sql-interleave ] } { \ having [ "having" "," sql-interleave ] } { \ order-by [ "order by" "," sql-interleave ] } @@ -51,7 +66,7 @@ DEFER: sql% ERROR: no-sql-match ; : sql% ( obj -- ) { - { [ dup string? ] [ " " 0% 0% ] } + { [ dup string? ] [ 0, ] } { [ dup array? ] [ sql-array% ] } { [ dup number? ] [ number>string sql% ] } { [ dup symbol? ] [ unparse sql% ] } @@ -61,13 +76,4 @@ ERROR: no-sql-match ; } cond ; : parse-sql ( obj -- sql in-spec out-spec in out ) - [ - unclip { - { \ create [ "create table" sql% ] } - { \ drop [ "drop table" sql% ] } - { \ insert [ "insert into" sql% ] } - { \ update [ "update" sql% ] } - { \ delete [ "delete" sql% ] } - { \ select [ "select" sql% ] } - } case [ sql% ] each - ] { "" { } { } { } { } } nmake ; + [ [ sql% ] each ] { { } { } { } } nmake ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index f9a597e814..665afa6a51 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -227,7 +227,7 @@ TUPLE: exam id name score ; : random-exam ( -- exam ) f - 6 [ CHAR: a CHAR: b [a,b] random ] replicate >string + 6 [ CHAR: a CHAR: z [a,b] random ] replicate >string 100 random exam boa ; @@ -340,7 +340,9 @@ TUPLE: exam id name score ; } ] [ T{ exam } select-tuples - ] unit-test ; + ] unit-test + + [ 4 ] [ T{ exam } count-tuples ] unit-test ; TUPLE: bignum-test id m n o ; : ( m n o -- obj ) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 09fd63b233..d121e06445 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -42,8 +42,9 @@ HOOK: db ( class -- obj ) HOOK: db ( class -- obj ) HOOK: db ( tuple class -- obj ) HOOK: db ( tuple class -- tuple ) -TUPLE: advanced-statement group order offset limit ; -HOOK: db ( tuple class group order offset limit -- tuple ) +TUPLE: query group order offset limit ; +HOOK: db ( tuple class group order offset limit -- tuple ) +HOOK: db ( tuple class -- n ) HOOK: insert-tuple* db ( tuple statement -- ) @@ -152,9 +153,20 @@ M: retryable execute-statement* ( statement type -- ) dup dup class do-select ; : select-tuple ( tuple -- tuple/f ) - dup dup class f f f 1 + dup dup class f f f 1 do-select ?first ; -: advanced-select ( tuple groups order offset limit -- tuples ) +: query ( tuple groups order offset limit -- tuples ) >r >r >r >r dup dup class r> r> r> r> - do-select ; + do-select ; + +: do-count ( exemplar-tuple statement -- tuples ) + [ + [ bind-tuple ] [ nip default-query ] 2bi + ] with-disposal ; + +: count-tuples ( tuple groups -- n ) + >r dup dup class r> do-count + dup length 1 = [ first first string>number ] [ + [ first string>number ] map + ] if ; From a0dbee6e2a2c26e24f5a5d9ca492a684ab3d2ddf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 8 Jun 2008 16:33:07 -0500 Subject: [PATCH 005/354] clean up html parser prettyprinter a bit --- extra/html/parser/printer/printer.factor | 47 +++++++++++++++++------- extra/html/parser/utils/utils.factor | 11 ++---- 2 files changed, 36 insertions(+), 22 deletions(-) diff --git a/extra/html/parser/printer/printer.factor b/extra/html/parser/printer/printer.factor index 3078cf23a5..d352a97688 100644 --- a/extra/html/parser/printer/printer.factor +++ b/extra/html/parser/printer/printer.factor @@ -2,7 +2,7 @@ USING: assocs html.parser html.parser.utils combinators continuations hashtables hashtables.private io kernel math namespaces prettyprint quotations sequences splitting -state-parser strings ; +strings ; IN: html.parser.printer SYMBOL: no-section @@ -16,7 +16,8 @@ TUPLE: state section ; TUPLE: text-printer ; TUPLE: ui-printer ; TUPLE: src-printer ; -UNION: printer text-printer ui-printer src-printer ; +TUPLE: html-prettyprinter ; +UNION: printer text-printer ui-printer src-printer html-prettyprinter ; HOOK: print-tag printer ( tag -- ) HOOK: print-text-tag printer ( tag -- ) HOOK: print-comment-tag printer ( tag -- ) @@ -47,7 +48,7 @@ M: printer print-comment-tag ( tag -- ) tag-text write "-->" write ; -M: printer print-dtd-tag +M: printer print-dtd-tag ( tag -- ) "" write ; @@ -70,8 +71,8 @@ M: printer print-closing-named-tag ( tag -- ) M: src-printer print-opening-named-tag ( tag -- ) "<" write - dup tag-name write - tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if + [ tag-name write ] + [ tag-attributes dup assoc-empty? [ drop ] [ print-attributes ] if ] bi ">" write ; M: src-printer print-closing-named-tag ( tag -- ) @@ -79,9 +80,30 @@ M: src-printer print-closing-named-tag ( tag -- ) tag-name write ">" write ; -TUPLE: unknown-tag-error tag ; +SYMBOL: tab-width +SYMBOL: #indentations -C: unknown-tag-error +: html-pp ( vector -- ) + [ + 0 #indentations set + 2 tab-width set + + ] with-scope ; + +: print-tabs ( -- ) + tab-width get #indentations get * CHAR: \s write ; + +M: html-prettyprinter print-opening-named-tag ( tag -- ) + print-tabs "<" write + tag-name write + ">\n" write ; + +M: html-prettyprinter print-closing-named-tag ( tag -- ) + "" write ; + +ERROR: unknown-tag-error tag ; M: printer print-tag ( tag -- ) { @@ -92,15 +114,12 @@ M: printer print-tag ( tag -- ) [ print-closing-named-tag ] } { [ dup tag-name string? ] [ print-opening-named-tag ] } - [ throw ] + [ unknown-tag-error ] } cond ; -SYMBOL: tablestack - -: with-html-printer - [ - V{ } clone tablestack set - ] with-scope ; +! SYMBOL: tablestack +! : with-html-printer ( vector quot -- ) + ! [ V{ } clone tablestack set ] with-scope ; ! { { 1 2 } { 3 4 } } ! H{ { table-gap { 10 10 } } } [ diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor index 5083b1cec2..592503e3dd 100644 --- a/extra/html/parser/utils/utils.factor +++ b/extra/html/parser/utils/utils.factor @@ -1,7 +1,7 @@ USING: assocs circular combinators continuations hashtables hashtables.private io kernel math namespaces prettyprint quotations sequences splitting -state-parser strings ; +state-parser strings sequences.lib ; IN: html.parser.utils : string-parse-end? @@ -13,7 +13,7 @@ IN: html.parser.utils dup length rot length 1- - head next* ; : trim1 ( seq ch -- newseq ) - [ ?head drop ] keep ?tail drop ; + [ ?head drop ] [ ?tail drop ] bi ; : single-quote ( str -- newstr ) >r "'" r> "'" 3append ; @@ -26,11 +26,7 @@ IN: html.parser.utils [ double-quote ] [ single-quote ] if ; : quoted? ( str -- ? ) - dup length 1 > [ - [ first ] keep peek [ = ] keep "'\"" member? and - ] [ - drop f - ] if ; + [ [ first ] [ peek ] bi [ = ] keep "'\"" member? and ] [ f ] if-seq ; : ?quote ( str -- newstr ) dup quoted? [ quote ] unless ; @@ -39,4 +35,3 @@ IN: html.parser.utils dup quoted? [ but-last-slice rest-slice >string ] when ; : quote? ( ch -- ? ) "'\"" member? ; - From a368b5ad487cfa5f1a11f9cef111576824f6d23c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jun 2008 17:08:19 -0500 Subject: [PATCH 006/354] Clarification --- core/parser/parser-docs.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 1dc47432d3..2ec9f2de54 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -117,14 +117,18 @@ $nl { $subsection parse-tokens } ; ARTICLE: "parsing-words" "Parsing words" -"The Factor parser is follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately." +"The Factor parser follows a simple recursive-descent design. The parser reads successive tokens from the input; if the token identifies a number or an ordinary word, it is added to an accumulator vector. Otherwise if the token identifies a parsing word, the parsing word is executed immediately." $nl "Parsing words are marked by suffixing the definition with a " { $link POSTPONE: parsing } " declaration. Here is the simplest possible parsing word; it prints a greeting at parse time:" { $code ": hello \"Hello world\" print ; parsing" } -"Parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser. Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can." +"Parsing words must not pop or push items from the stack; however, they are permitted to access the accumulator vector supplied by the parser at the top of the stack. That is, parsing words must have stack effect " { $snippet "( accum -- accum )" } ", where " { $snippet "accum" } " is the accumulator vector supplied by the parser." +$nl +"Parsing words can read input, add word definitions to the dictionary, and do anything an ordinary word can." +$nl +"Because of the stack restriction, parsing words cannot pass data to other words by leaving values on the stack; instead, use " { $link parsed } " to add the data to the parse tree so that it can be evaluated later." $nl "Parsing words cannot be called from the same source file where they are defined, because new definitions are only compiled at the end of the source file. An attempt to use a parsing word in its own source file raises an error:" -{ $link staging-violation } +{ $subsection staging-violation } "Tools for implementing parsing words:" { $subsection "reading-ahead" } { $subsection "parsing-word-nest" } From 5f9aca57251855e866260af313b60548755a5bea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Jun 2008 18:04:01 -0500 Subject: [PATCH 007/354] refactor add url objects --- extra/db/postgresql/lib/lib.factor | 4 +++- extra/db/postgresql/postgresql.factor | 1 + extra/db/queries/queries.factor | 10 +++++----- extra/db/sqlite/lib/lib.factor | 4 +++- extra/db/sqlite/sqlite.factor | 1 + extra/db/tuples/tuples-tests.factor | 2 +- extra/db/tuples/tuples.factor | 22 ++++++++-------------- extra/db/types/types.factor | 2 +- 8 files changed, 23 insertions(+), 23 deletions(-) diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index e99bc41449..9d2ced3afa 100755 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -5,7 +5,7 @@ quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators libc shuffle calendar.format byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary io.encodings.utf8 -alien.strings io.streams.byte-array inspector ; +alien.strings io.streams.byte-array inspector present urls ; IN: db.postgresql.lib : postgresql-result-error-message ( res -- str/f ) @@ -84,6 +84,7 @@ M: postgresql-result-null summary ( obj -- str ) { TIME [ dup [ timestamp>hms ] when default-param-value ] } { DATETIME [ dup [ timestamp>ymdhms ] when default-param-value ] } { TIMESTAMP [ dup [ timestamp>ymdhms ] when default-param-value ] } + { URL [ dup [ present ] when default-param-value ] } [ drop default-param-value ] } case 2array ] 2map flip dup empty? [ @@ -164,6 +165,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) { TIMESTAMP [ pq-get-string dup [ ymdhms>timestamp ] when ] } { DATETIME [ pq-get-string dup [ ymdhms>timestamp ] when ] } { BLOB [ pq-get-blob ] } + { URL [ pq-get-string dup [ >url ] when ] } { FACTOR-BLOB [ pq-get-blob dup [ bytes>object ] when ] } diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index f55897db88..1734fb6df4 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -239,6 +239,7 @@ M: postgresql-db persistent-table ( -- hashtable ) { TIMESTAMP { "timestamp" "timestamp" f } } { BLOB { "bytea" "bytea" f } } { FACTOR-BLOB { "bytea" "bytea" f } } + { URL { "string" "string" f } } { +foreign-id+ { f f "references" } } { +autoincrement+ { f f "autoincrement" } } { +unique+ { f f "unique" } } diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 29abe9bddc..807aeda74a 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -149,14 +149,13 @@ M: db ( tuple class -- statement ) : make-query ( tuple query -- tuple' ) dupd { - [ group>> [ do-group ] [ drop ] if* ] - [ order>> [ do-order ] [ drop ] if* ] + [ group>> [ do-group ] [ drop ] if-seq ] + [ order>> [ do-order ] [ drop ] if-seq ] [ limit>> [ do-limit ] [ drop ] if* ] [ offset>> [ do-offset ] [ drop ] if* ] } 2cleave ; -M: db ( tuple class group order limit offset -- tuple ) - \ query boa +M: db ( tuple class query -- tuple ) [ ] dip make-query ; ! select ID, NAME, SCORE from EXAM limit 1 offset 3 @@ -174,7 +173,8 @@ M: db ( tuple class group order limit offset -- tuple ) maybe-make-retryable do-select ; M: db ( tuple class groups -- statement ) - f f f \ query boa + \ query new + swap >>group [ [ "select count(*) from " 0% 0% where-clause ] query-make ] dip make-query ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index b652e8fed7..4c440acc55 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser namespaces sequences db.sqlite.ffi db combinators continuations db.types calendar.format serialize io.streams.byte-array byte-arrays io.encodings.binary -io.backend db.errors ; +io.backend db.errors present urls ; IN: db.sqlite.lib ERROR: sqlite-error < db-error n string ; @@ -107,6 +107,7 @@ ERROR: sqlite-sql-error < sql-error n string ; object>bytes sqlite-bind-blob-by-name ] } + { URL [ present sqlite-bind-text-by-name ] } { +db-assigned-id+ [ sqlite-bind-int-by-name ] } { +random-id+ [ sqlite-bind-int64-by-name ] } { NULL [ sqlite-bind-null-by-name ] } @@ -147,6 +148,7 @@ ERROR: sqlite-sql-error < sql-error n string ; { TIMESTAMP [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } { DATETIME [ sqlite3_column_text dup [ ymdhms>timestamp ] when ] } { BLOB [ sqlite-column-blob ] } + { URL [ sqlite3_column_text dup [ >url ] when ] } { FACTOR-BLOB [ sqlite-column-blob dup [ bytes>object ] when diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index cc4e4d116a..c7c9065b43 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -182,6 +182,7 @@ M: sqlite-db persistent-table ( -- assoc ) { DOUBLE { "real" "real" } } { BLOB { "blob" "blob" } } { FACTOR-BLOB { "blob" "blob" } } + { URL { "text" "text" } } { +autoincrement+ { f f "autoincrement" } } { +unique+ { f f "unique" } } { +default+ { f f "default" } } diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 665afa6a51..7ccee7c637 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -342,7 +342,7 @@ TUPLE: exam id name score ; T{ exam } select-tuples ] unit-test - [ 4 ] [ T{ exam } count-tuples ] unit-test ; + [ 4 ] [ T{ exam } f count-tuples ] unit-test ; TUPLE: bignum-test id m n o ; : ( m n o -- obj ) diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index b7cc6c81c2..4903adff5c 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -43,8 +43,8 @@ HOOK: db ( class -- obj ) HOOK: db ( tuple class -- obj ) HOOK: db ( tuple class -- tuple ) TUPLE: query group order offset limit ; -HOOK: db ( tuple class group order offset limit -- tuple ) -HOOK: db ( tuple class -- n ) +HOOK: db ( tuple class query -- statement' ) +HOOK: db ( tuple class groups -- n ) HOOK: insert-tuple* db ( tuple statement -- ) @@ -149,19 +149,14 @@ M: retryable execute-statement* ( statement type -- ) : do-select ( exemplar-tuple statement -- tuples ) [ [ bind-tuple ] [ query-tuples ] 2bi ] with-disposal ; +: query ( tuple query -- tuples ) + >r dup dup class r> do-select ; + : select-tuples ( tuple -- tuples ) dup dup class do-select ; -: count-tuples ( tuple -- n ) - select-tuples length ; - : select-tuple ( tuple -- tuple/f ) - dup dup class f f f 1 - do-select ?first ; - -: query ( tuple groups order offset limit -- tuples ) - >r >r >r >r dup dup class r> r> r> r> - do-select ; + dup dup class \ query new 1 >>limit do-select ?first ; : do-count ( exemplar-tuple statement -- tuples ) [ @@ -170,6 +165,5 @@ M: retryable execute-statement* ( statement type -- ) : count-tuples ( tuple groups -- n ) >r dup dup class r> do-count - dup length 1 = [ first first string>number ] [ - [ first string>number ] map - ] if ; + dup length 1 = + [ first first string>number ] [ [ first string>number ] map ] if ; diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 03e6b15bdb..f6d54404de 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -65,7 +65,7 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB -FACTOR-BLOB NULL ; +FACTOR-BLOB NULL URL ; : spec>tuple ( class spec -- tuple ) 3 f pad-right From a226bf5de846eb74fb6f2cb9d8d207fd2f83b8db Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Jun 2008 18:20:15 -0500 Subject: [PATCH 008/354] fix url objects, use new accessors more in db.tuples-tests --- extra/db/postgresql/postgresql.factor | 2 +- extra/db/tuples/tuples-tests.factor | 47 ++++++++++++++------------- 2 files changed, 26 insertions(+), 23 deletions(-) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 1734fb6df4..e57efbc360 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -239,7 +239,7 @@ M: postgresql-db persistent-table ( -- hashtable ) { TIMESTAMP { "timestamp" "timestamp" f } } { BLOB { "bytea" "bytea" f } } { FACTOR-BLOB { "bytea" "bytea" f } } - { URL { "string" "string" f } } + { URL { "varchar" "varchar" f } } { +foreign-id+ { f f "references" } } { +autoincrement+ { f f "autoincrement" } } { +unique+ { f f "unique" } } diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 7ccee7c637..b5b80355fe 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -8,22 +8,23 @@ math.ranges strings sequences.lib ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real -ts date time blob factor-blob ; +ts date time blob factor-blob url ; -: ( name age real ts date time blob factor-blob -- person ) - { - set-person-the-name - set-person-the-number - set-person-the-real - set-person-ts - set-person-date - set-person-time - set-person-blob - set-person-factor-blob - } person construct ; +: ( name age real ts date time blob factor-blob url -- person ) + person new + swap >>url + swap >>factor-blob + swap >>blob + swap >>time + swap >>date + swap >>ts + swap >>the-real + swap >>the-number + swap >>the-name ; -: ( id name age real ts date time blob factor-blob -- person ) - [ set-person-the-id ] keep ; +: ( id name age real ts date time blob factor-blob url -- person ) + + swap >>the-id ; SYMBOL: person1 SYMBOL: person2 @@ -120,19 +121,20 @@ SYMBOL: person4 { "time" "T" TIME } { "blob" "B" BLOB } { "factor-blob" "FB" FACTOR-BLOB } + { "url" "U" URL } } define-persistent - "billy" 10 3.14 f f f f f person1 set - "johnny" 10 3.14 f f f f f person2 set + "billy" 10 3.14 f f f f f f person1 set + "johnny" 10 3.14 f f f f f f person2 set "teddy" 10 3.14 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } - B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f person3 set + B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f person3 set "eddie" 10 3.14 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } - f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; + f H{ { 1 2 } { 3 4 } { 5 "lol" } } f person4 set ; : user-assigned-person-schema ( -- ) person "PERSON" @@ -146,20 +148,21 @@ SYMBOL: person4 { "time" "T" TIME } { "blob" "B" BLOB } { "factor-blob" "FB" FACTOR-BLOB } + { "url" "U" URL } } define-persistent - 1 "billy" 10 3.14 f f f f f person1 set - 2 "johnny" 10 3.14 f f f f f person2 set + 1 "billy" 10 3.14 f f f f f f person1 set + 2 "johnny" 10 3.14 f f f f f f person2 set 3 "teddy" 10 3.14 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } B{ 115 116 111 114 101 105 110 97 98 108 111 98 } - f person3 set + f f person3 set 4 "eddie" 10 3.14 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } - f H{ { 1 2 } { 3 4 } { 5 "lol" } } person4 set ; + f H{ { 1 2 } { 3 4 } { 5 "lol" } } f person4 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; From 216bf23e6c6687123ef8af4ece65ad0f889c7e7c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 12 Jun 2008 18:23:46 -0500 Subject: [PATCH 009/354] test url objects --- extra/db/tuples/tuples-tests.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index b5b80355fe..36e84187eb 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -4,7 +4,7 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals db.postgresql accessors random math.bitfields.lib -math.ranges strings sequences.lib ; +math.ranges strings sequences.lib urls ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real @@ -104,6 +104,7 @@ SYMBOL: person4 T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } f H{ { 1 2 } { 3 4 } { 5 "lol" } } + URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" } ] [ T{ person f 4 } select-tuple ] unit-test @@ -134,7 +135,7 @@ SYMBOL: person4 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } - f H{ { 1 2 } { 3 4 } { 5 "lol" } } f person4 set ; + f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" person4 set ; : user-assigned-person-schema ( -- ) person "PERSON" @@ -162,7 +163,7 @@ SYMBOL: person4 T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } } T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } } - f H{ { 1 2 } { 3 4 } { 5 "lol" } } f person4 set ; + f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" person4 set ; TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; From a89c9758df900de8faace1661ec9e3a2e4310e3c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jun 2008 18:53:53 -0500 Subject: [PATCH 010/354] Check port number --- extra/http/http-tests.factor | 8 ++++---- extra/http/http.factor | 9 +-------- extra/http/server/server.factor | 26 +++++++++++++++++++++----- extra/io/server/server.factor | 10 ++++++---- 4 files changed, 32 insertions(+), 21 deletions(-) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 81ada558f3..aa11dd6798 100755 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -7,7 +7,7 @@ IN: http.tests : lf>crlf "\n" split "\r\n" join ; STRING: read-request-test-1 -POST http://foo/bar HTTP/1.1 +POST /bar HTTP/1.1 Some-Header: 1 Some-Header: 2 Content-Length: 4 @@ -18,7 +18,7 @@ blah [ TUPLE{ request - url: TUPLE{ url protocol: "http" port: 80 path: "/bar" } + url: TUPLE{ url path: "/bar" } method: "POST" version: "1.1" header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } @@ -49,14 +49,14 @@ read-request-test-1' 1array [ ] unit-test STRING: read-request-test-2 -HEAD http://foo/bar HTTP/1.1 +HEAD /bar HTTP/1.1 Host: www.sex.com ; [ TUPLE{ request - url: TUPLE{ url protocol: "http" port: 80 host: "www.sex.com" path: "/bar" } + url: TUPLE{ url host: "www.sex.com" path: "/bar" } method: "HEAD" version: "1.1" header: H{ { "host" "www.sex.com" } } diff --git a/extra/http/http.factor b/extra/http/http.factor index d7fc1b766e..521c18c703 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -6,8 +6,7 @@ assocs sequences splitting sorting sets debugger strings vectors hashtables quotations arrays byte-arrays math.parser calendar calendar.format present -io io.server io.sockets.secure -io.encodings.iana io.encodings.binary io.encodings.8-bit +io io.encodings.iana io.encodings.binary io.encodings.8-bit unicode.case unicode.categories qualified @@ -142,7 +141,6 @@ cookies ; request new "1.1" >>version - "http" >>protocol H{ } clone >>query >>url H{ } clone >>header @@ -202,7 +200,6 @@ TUPLE: post-data raw content content-type ; : extract-host ( request -- request ) [ ] [ url>> ] [ "host" header parse-host ] tri [ >>host ] [ >>port ] bi* - ensure-port drop ; : extract-cookies ( request -- request ) @@ -214,9 +211,6 @@ TUPLE: post-data raw content content-type ; : parse-content-type ( content-type -- type encoding ) ";" split1 parse-content-type-attributes "charset" swap at ; -: detect-protocol ( request -- request ) - dup url>> remote-address get secure? "https" "http" ? >>protocol drop ; - : read-request ( -- request ) read-method @@ -224,7 +218,6 @@ TUPLE: post-data raw content content-type ; read-request-version read-request-header read-post-data - detect-protocol extract-host extract-cookies ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 792757b182..642e9f77f0 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,16 +2,18 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences arrays namespaces splitting vocabs.loader destructors assocs debugger continuations -tools.vocabs math +combinators tools.vocabs math io io.server +io.sockets +io.sockets.secure io.encodings io.encodings.utf8 io.encodings.ascii io.encodings.binary io.streams.limited io.timeouts -fry logging calendar +fry logging calendar urls http http.server.responses html.elements @@ -88,12 +90,26 @@ LOG: httpd-hit NOTICE : dispatch-request ( request -- response ) url>> path>> split-path main-responder get call-responder ; +: prepare-request ( request -- request ) + [ + local-address get + [ secure? "https" "http" ? >>protocol ] + [ port>> '[ , or ] change-port ] + bi + ] change-url ; + +: valid-request? ( request -- ? ) + url>> port>> local-address get port>> = ; + : do-request ( request -- response ) '[ , - [ init-request ] - [ log-request ] - [ dispatch-request ] tri + { + [ init-request ] + [ prepare-request ] + [ log-request ] + [ dup valid-request? [ dispatch-request ] [ drop <400> ] if ] + } cleave ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ; : ?refresh-all ( -- ) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 359b9c6fb4..c855fba6be 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -4,7 +4,7 @@ USING: io io.sockets io.sockets.secure io.files io.streams.duplex logging continuations destructors kernel math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar threads concurrency.combinators -assocs fry ; +assocs fry accessors ; IN: io.server SYMBOL: servers @@ -15,9 +15,10 @@ SYMBOL: remote-address LOG: accepted-connection NOTICE -: with-connection ( client remote quot -- ) +: with-connection ( client remote local quot -- ) '[ , [ remote-address set ] [ accepted-connection ] bi + , local-address set @ ] with-stream ; inline @@ -25,7 +26,8 @@ LOG: accepted-connection NOTICE : accept-loop ( server quot -- ) [ - >r accept r> '[ , , , with-connection ] "Client" spawn drop + [ [ accept ] [ addr>> ] bi ] dip + '[ , , , , with-connection ] "Client" spawn drop ] 2keep accept-loop ; inline : server-loop ( addrspec encoding quot -- ) @@ -59,7 +61,7 @@ LOG: received-datagram NOTICE : datagram-loop ( quot datagram -- ) [ - [ receive dup received-datagram >r swap call r> ] keep + [ receive dup received-datagram [ swap call ] dip ] keep pick [ send ] [ 3drop ] if ] 2keep datagram-loop ; inline From 9aadcace246947ccadd04c7ca122ea5162230991 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jun 2008 18:54:38 -0500 Subject: [PATCH 011/354] Fix pool behavior with image save/restart --- extra/io/pools/pools.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/io/pools/pools.factor b/extra/io/pools/pools.factor index 033ba3cbfb..0e37e41a76 100644 --- a/extra/io/pools/pools.factor +++ b/extra/io/pools/pools.factor @@ -10,7 +10,7 @@ TUPLE: pool connections disposed expired ; dup check-disposed dup expired>> expired? [ ALIEN: 31337 >>expired - connections>> [ delete-all ] [ dispose-each ] bi + connections>> delete-all ] [ drop ] if ; : ( class -- pool ) @@ -34,6 +34,7 @@ GENERIC: make-connection ( pool -- conn ) dup check-pool [ make-connection ] keep return-connection ; : acquire-connection ( pool -- conn ) + dup check-pool [ dup connections>> empty? ] [ dup new-connection ] [ ] while connections>> pop ; From 3358381510851552d7c3d3005dff884bf303d11f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jun 2008 18:54:50 -0500 Subject: [PATCH 012/354] Better support for rest parameters on URLs --- extra/furnace/furnace.factor | 51 ++++++++++++++---------------- extra/webapps/blogs/blogs.factor | 2 ++ extra/webapps/blogs/edit-post.xml | 4 +-- extra/webapps/blogs/list-posts.xml | 6 ++-- extra/webapps/blogs/user-posts.xml | 8 ++--- extra/webapps/blogs/view-post.xml | 8 ++--- extra/webapps/wiki/articles.xml | 2 +- extra/webapps/wiki/changes.xml | 32 ++++++++++++------- extra/webapps/wiki/diff.xml | 4 +-- extra/webapps/wiki/page-common.xml | 8 ++--- extra/webapps/wiki/revisions.xml | 10 +++--- extra/webapps/wiki/user-edits.xml | 6 ++-- extra/webapps/wiki/view.xml | 2 +- extra/webapps/wiki/wiki.factor | 42 +++++++++++------------- 14 files changed, 93 insertions(+), 92 deletions(-) diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 99ccf33eec..6ddd84a254 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -97,15 +97,21 @@ SYMBOL: exit-continuation dup empty? [ drop f ] [ "," split [ dup value ] H{ } map>assoc ] if ; -CHLOE: atom - [ children>string ] - [ "href" required-attr ] - [ "query" optional-attr parse-query-attr ] tri - - swap >>query - swap >>path - adjust-url relative-to-request - add-atom-feed ; +: a-url-path ( tag -- string ) + [ "href" required-attr ] [ "rest" optional-attr value ] bi + [ [ "/" ?tail drop "/" ] dip present 3append ] when* ; + +: a-url ( tag -- url ) + dup "value" optional-attr [ ] [ + + swap + [ a-url-path >>path ] + [ "query" optional-attr parse-query-attr >>query ] + bi + ] ?if + adjust-url relative-to-request ; + +CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ; CHLOE: write-atom drop write-atom-feeds ; @@ -114,23 +120,11 @@ GENERIC: link-attr ( tag responder -- ) M: object link-attr 2drop ; : link-attrs ( tag -- ) + #! Side-effects current namespace. '[ , _ link-attr ] each-responder ; : a-start-tag ( tag -- ) - [ - - swap >>query - swap >>path - adjust-url relative-to-request =href - a> - ] with-scope ; + [ ] with-scope ; CHLOE: a [ a-start-tag ] @@ -158,11 +152,12 @@ CHLOE: a [ [
] [ form-magic ] bi diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 8dbf7db690..882584f014 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -164,6 +164,8 @@ M: comment entity-url : ( -- action ) + "id" >>rest + [ validate-integer-id "id" value select-tuple from-object diff --git a/extra/webapps/blogs/edit-post.xml b/extra/webapps/blogs/edit-post.xml index da88a78ab0..4522f8606b 100644 --- a/extra/webapps/blogs/edit-post.xml +++ b/extra/webapps/blogs/edit-post.xml @@ -15,13 +15,13 @@
Post by - + on | - View Post + View Post | Delete Post
diff --git a/extra/webapps/blogs/list-posts.xml b/extra/webapps/blogs/list-posts.xml index 9c9685fe74..94a5a69775 100644 --- a/extra/webapps/blogs/list-posts.xml +++ b/extra/webapps/blogs/list-posts.xml @@ -7,7 +7,7 @@

- +

@@ -18,13 +18,13 @@
Post by - + on | - + comments. diff --git a/extra/webapps/blogs/user-posts.xml b/extra/webapps/blogs/user-posts.xml index 95fae23b34..d94b598fc0 100644 --- a/extra/webapps/blogs/user-posts.xml +++ b/extra/webapps/blogs/user-posts.xml @@ -2,7 +2,7 @@ - + Recent Posts by @@ -13,7 +13,7 @@

- +

@@ -24,13 +24,13 @@
Post by - + on | - + comments. diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml index 23bf513946..fae9ff3e76 100644 --- a/extra/webapps/blogs/view-post.xml +++ b/extra/webapps/blogs/view-post.xml @@ -2,11 +2,11 @@ - + : - + Recent Posts by @@ -18,13 +18,13 @@
Post by - + on | - Edit Post + Edit Post | Delete Post
diff --git a/extra/webapps/wiki/articles.xml b/extra/webapps/wiki/articles.xml index e19c531d3d..9b2ae930fb 100644 --- a/extra/webapps/wiki/articles.xml +++ b/extra/webapps/wiki/articles.xml @@ -7,7 +7,7 @@
  • - +
diff --git a/extra/webapps/wiki/changes.xml b/extra/webapps/wiki/changes.xml index 5b3e9de2c4..1515c4924a 100644 --- a/extra/webapps/wiki/changes.xml +++ b/extra/webapps/wiki/changes.xml @@ -4,16 +4,26 @@ Recent Changes -
    - -
  • - - on - - by - -
    • -     -
+
+ + + + + + + + + + + + + + + + + +
ArticleDateBy
+ +
diff --git a/extra/webapps/wiki/diff.xml b/extra/webapps/wiki/diff.xml index 35afe51b66..9d65531eb0 100644 --- a/extra/webapps/wiki/diff.xml +++ b/extra/webapps/wiki/diff.xml @@ -8,13 +8,13 @@ Old revision: - Created on by . + Created on by . New revision: - Created on by . + Created on by . diff --git a/extra/webapps/wiki/page-common.xml b/extra/webapps/wiki/page-common.xml index 675cb8cd65..0d029946f8 100644 --- a/extra/webapps/wiki/page-common.xml +++ b/extra/webapps/wiki/page-common.xml @@ -2,16 +2,16 @@ - + Revisions of
- Latest - | Revisions - | Edit + Latest + | Revisions + | Edit | Delete
diff --git a/extra/webapps/wiki/revisions.xml b/extra/webapps/wiki/revisions.xml index 2a909e6ab3..97a051cd96 100644 --- a/extra/webapps/wiki/revisions.xml +++ b/extra/webapps/wiki/revisions.xml @@ -8,14 +8,14 @@ - + - - + + @@ -24,7 +24,7 @@

View Differences

- +
RevisionAuthorBy Rollback
Rollback
@@ -51,6 +51,6 @@
Old revision:
- + diff --git a/extra/webapps/wiki/user-edits.xml b/extra/webapps/wiki/user-edits.xml index 6f22982f12..6f6ada2dbd 100644 --- a/extra/webapps/wiki/user-edits.xml +++ b/extra/webapps/wiki/user-edits.xml @@ -2,7 +2,7 @@ - + Edits by @@ -11,9 +11,9 @@
  • - + on - +
diff --git a/extra/webapps/wiki/view.xml b/extra/webapps/wiki/view.xml index 30dfb71270..7d2c7869b5 100644 --- a/extra/webapps/wiki/view.xml +++ b/extra/webapps/wiki/view.xml @@ -8,6 +8,6 @@
-

This revision created on by .

+

This revision created on by .

 diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 21a983fc7b..4791278974 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel hashtables calendar -namespaces splitting sequences sorting math.order +namespaces splitting sequences sorting math.order present html.components syndication http.server http.server.dispatchers @@ -15,20 +15,19 @@ validators db.types db.tuples lcs farkup urls ; IN: webapps.wiki -: view-url ( title -- url ) - "$wiki/view/" prepend >url ; +: wiki-url ( rest path -- url ) + [ "$wiki/" % % "/" % % ] "" make + swap >>path ; -: edit-url ( title -- url ) - "$wiki/edit" >url swap "title" set-query-param ; +: view-url ( title -- url ) "view" wiki-url ; -: revisions-url ( title -- url ) - "$wiki/revisions" >url swap "title" set-query-param ; +: edit-url ( title -- url ) "edit" wiki-url ; -: revision-url ( id -- url ) - "$wiki/revision" >url swap "id" set-query-param ; +: revisions-url ( title -- url ) "revisions" wiki-url ; -: user-edits-url ( author -- url ) - "$wiki/user-edits" >url swap "author" set-query-param ; +: revision-url ( id -- url ) "revision" wiki-url ; + +: user-edits-url ( author -- url ) "user-edits" wiki-url ; TUPLE: wiki < dispatcher ; @@ -83,12 +82,9 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) "title" >>rest - [ validate-title - "view?title=" relative-link-prefix set ] >>init - [ "title" value dup
select-tuple [ revision>> select-tuple from-object @@ -100,13 +96,13 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "id" >>rest [ validate-integer-id "id" value select-tuple from-object - "view?title=" relative-link-prefix set + URL" $wiki/view/" adjust-url present relative-link-prefix set ] >>init - { wiki "view" } >>template ; : add-revision ( revision -- ) @@ -121,15 +117,14 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "title" >>rest [ validate-title "title" value
select-tuple [ revision>> select-tuple from-object ] when* ] >>init - { wiki "edit" } >>template - [ validate-title { { "content" [ v-required ] } } validate-params @@ -148,6 +143,7 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "title" >>rest [ validate-title list-revisions "revisions" set-value @@ -156,6 +152,7 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "title" >>rest [ validate-title ] >>init [ "Revisions of " "title" value append ] >>title [ "title" value revisions-url ] >>url @@ -164,20 +161,18 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) [ validate-integer-id ] >>validate - [ "id" value select-tuple clone f >>id [ add-revision ] [ title>> view-url ] bi ] >>submit ; : list-changes ( -- seq ) - "id" value select-tuples + f select-tuples reverse-chronological-order ; : ( -- action ) [ list-changes "changes" set-value ] >>init - { wiki "changes" } >>template ; : ( -- action ) @@ -189,7 +184,6 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) [ validate-title ] >>validate - [ "title" value
delete-tuples f "title" value >>title delete-tuples @@ -213,7 +207,6 @@ M: revision feed-entry-url id>> revision-url ; [ [ content>> string-lines ] bi@ diff "diff" set-value ] 2bi ] >>init - { wiki "diff" } >>template ; : ( -- action ) @@ -223,7 +216,6 @@ M: revision feed-entry-url id>> revision-url ; [ [ title>> ] compare ] sort "articles" set-value ] >>init - { wiki "articles" } >>template ; : list-user-edits ( -- seq ) @@ -232,6 +224,7 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "author" >>rest [ validate-author list-user-edits "user-edits" set-value @@ -240,6 +233,7 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "author" >>rest [ validate-author ] >>init [ "Edits by " "author" value append ] >>title [ "author" value user-edits-url ] >>url From 61a9a8c0ec36086e9ee69318978e287a0e78cde0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jun 2008 18:59:06 -0500 Subject: [PATCH 013/354] Fix --- core/grouping/grouping-tests.factor | 2 ++ core/grouping/grouping.factor | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/core/grouping/grouping-tests.factor b/core/grouping/grouping-tests.factor index dcf62e1117..dc3d970fbf 100644 --- a/core/grouping/grouping-tests.factor +++ b/core/grouping/grouping-tests.factor @@ -10,3 +10,5 @@ IN: grouping.tests 2 over set-length >array ] unit-test + +[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 [ >array ] map ] unit-test diff --git a/core/grouping/grouping.factor b/core/grouping/grouping.factor index c12d43160c..caf46e5480 100644 --- a/core/grouping/grouping.factor +++ b/core/grouping/grouping.factor @@ -56,7 +56,7 @@ M: clumps set-length M: clumps group@ [ n>> over + ] [ seq>> ] bi ; -TUPLE: sliced-clumps < groups ; +TUPLE: sliced-clumps < clumps ; : ( seq n -- clumps ) sliced-clumps new-groups ; inline From 75ac2528ae18c6b80d7969357e9f108ea943f3f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Jun 2008 19:00:41 -0500 Subject: [PATCH 014/354] Remove obsolete comment --- extra/io/streams/duplex/duplex.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/extra/io/streams/duplex/duplex.factor b/extra/io/streams/duplex/duplex.factor index 02d7ab61be..51b4b8d860 100755 --- a/extra/io/streams/duplex/duplex.factor +++ b/extra/io/streams/duplex/duplex.factor @@ -5,9 +5,6 @@ io.encodings.private io.timeouts debugger inspector listener accessors delegate delegate.protocols ; IN: io.streams.duplex -! We ensure that the stream can only be closed once, to preserve -! integrity of duplex I/O ports. - TUPLE: duplex-stream in out ; C: duplex-stream From 73eff2b1900d90fb12e8eb869a9a830922d4aafc Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 12 Jun 2008 22:51:53 -0500 Subject: [PATCH 015/354] dns.server: Refine fill-authority and fill-additional --- extra/dns/server/server.factor | 44 +++++++++++++++++++++------------- 1 file changed, 28 insertions(+), 16 deletions(-) diff --git a/extra/dns/server/server.factor b/extra/dns/server/server.factor index 1e7d9cb622..de36d661aa 100644 --- a/extra/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -39,18 +39,13 @@ IN: dns.server zones sort-largest-first [ name-in-domain? ] with find nip ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! fill-authority +! name->authority ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: fill-authority ( message -- message ) - [ ] - [ message-query name>> name->zone NS IN query boa matching-rrs ] - [ answer-section>> ] - tri - diff >>authority-section ; +: name->authority ( name -- rrs-ns ) name->zone NS IN query boa matching-rrs ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! fill-additional +! extract-names ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : rr->rdata-names ( rr -- names/f ) @@ -61,12 +56,33 @@ IN: dns.server } cond ; +: extract-rdata-names ( message -- names ) + [ answer-section>> ] [ authority-section>> ] bi append + [ rr->rdata-names ] map concat ; + +: extract-names ( message -- names ) + [ message-query name>> ] [ extract-rdata-names ] bi prefix-on ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! fill-authority +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: fill-authority ( message -- message ) + dup + extract-names [ name->authority ] map concat prune + over answer-section>> diff + >>authority-section ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! fill-additional +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: name->rrs-a ( name -- rrs-a ) A IN query boa matching-rrs ; + : fill-additional ( message -- message ) dup - [ answer-section>> ] [ authority-section>> ] bi append - [ rr->rdata-names ] map concat - [ A IN query boa matching-rrs ] map concat prune - over answer-section>> diff + extract-rdata-names [ name->rrs-a ] map concat prune + over answer-section>> diff >>additional-section ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -90,10 +106,6 @@ DEFER: query->rrs ! have-answers ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : have-answers ( message -- message/f ) -! dup message-query query->rrs ! message rrs/f -! [ empty? ] [ 2drop f ] [ >>answer-section ] 1if ; - : have-answers ( message -- message/f ) dup message-query query->rrs [ empty? ] From 49523c508b12768adfc60ee5c254e718a851715d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Jun 2008 00:47:47 -0500 Subject: [PATCH 016/354] More flexible furnace authentication; fix planet --- extra/furnace/actions/actions.factor | 30 ++-- extra/furnace/auth/login/login.factor | 64 ++++--- extra/furnace/furnace.factor | 7 +- .../server/redirection/redirection.factor | 8 +- extra/http/server/server.factor | 2 +- extra/webapps/blogs/blogs.factor | 168 ++++++++++++------ .../blogs/{user-posts.xml => posts-by.xml} | 0 extra/webapps/blogs/view-post.xml | 2 +- extra/webapps/pastebin/pastebin.factor | 34 ++-- extra/webapps/planet/planet.factor | 28 +-- extra/webapps/wiki/wiki.factor | 56 ++++-- 11 files changed, 256 insertions(+), 143 deletions(-) rename extra/webapps/blogs/{user-posts.xml => posts-by.xml} (100%) diff --git a/extra/furnace/actions/actions.factor b/extra/furnace/actions/actions.factor index 1cef8e24e5..a281687096 100755 --- a/extra/furnace/actions/actions.factor +++ b/extra/furnace/actions/actions.factor @@ -29,14 +29,10 @@ SYMBOL: rest CHLOE: validation-messages drop render-validation-messages ; -TUPLE: action rest init display validate submit ; +TUPLE: action rest authorize init display validate submit ; : new-action ( class -- action ) - new - [ ] >>init - [ <400> ] >>display - [ ] >>validate - [ <400> ] >>submit ; + new [ ] >>init [ ] >>validate [ ] >>authorize ; inline : ( -- action ) action new-action ; @@ -46,18 +42,28 @@ TUPLE: action rest init display validate submit ; : handle-get ( action -- response ) '[ - , - [ init>> call ] - [ drop flashed-variables restore-flash ] - [ display>> call ] - tri + , dup display>> [ + { + [ init>> call ] + [ authorize>> call ] + [ drop flashed-variables restore-flash ] + [ display>> call ] + } cleave + ] [ drop <400> ] if ] with-exit-continuation ; : validation-failed ( -- * ) request get method>> "POST" = [ f ] [ <400> ] if exit-with ; : (handle-post) ( action -- response ) - [ validate>> call ] [ submit>> call ] bi ; + '[ + , dup submit>> [ + [ validate>> call ] + [ authorize>> call ] + [ submit>> call ] + tri + ] [ drop <400> ] if + ] with-exit-continuation ; : param ( name -- value ) params get at ; diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index d0c4e00953..a1d2bf47c3 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -49,6 +49,10 @@ TUPLE: login < dispatcher users checksum ; TUPLE: protected < filter-responder description capabilities ; +: ( responder -- protected ) + protected new + swap >>responder ; + : users ( -- provider ) login get users>> ; @@ -85,13 +89,17 @@ M: user-saver dispose "invalid username or password" validation-error validation-failed ; +SYMBOL: description +SYMBOL: capabilities + +: flashed-variables { description capabilities } ; + : ( -- action ) [ - protected fget [ - [ description>> "description" set-value ] - [ capabilities>> words>strings "capabilities" set-value ] bi - ] when* + flashed-variables restore-flash + description get "description" set-value + capabilities get words>strings "capabilities" set-value ] >>init { login "login" } >>template @@ -200,7 +208,10 @@ M: user-saver dispose drop URL" $login" end-aside - ] >>submit ; + ] >>submit + + + "edit your profile" >>description ; ! ! ! Password recovery @@ -316,32 +327,36 @@ SYMBOL: lost-password-from ] >>submit ; ! ! ! Authentication logic -: ( responder -- protected ) - protected new - swap >>responder ; - : show-login-page ( -- response ) begin-aside - URL" $login/login" { protected } ; + protected get description>> description set + protected get capabilities>> capabilities set + URL" $login/login" flashed-variables ; -: check-capabilities ( responder user -- ? ) - [ capabilities>> ] bi@ subset? ; +: login-required ( -- * ) + show-login-page exit-with ; + +: have-capability? ( capability -- ? ) + logged-in-user get capabilities>> member? ; + +: check-capabilities ( responder user/f -- ? ) + dup [ [ capabilities>> ] bi@ subset? ] [ 2drop f ] if ; M: protected call-responder* ( path responder -- response ) dup protected set - uid dup [ - users get-user 2dup check-capabilities [ - [ logged-in-user set ] [ save-user-after ] bi - call-next-method - ] [ - 3drop show-login-page - ] if - ] [ - 3drop show-login-page - ] if ; + dup logged-in-user get check-capabilities + [ call-next-method ] [ 2drop show-login-page ] if ; + +: init-user ( -- ) + uid [ + users get-user + [ logged-in-user set ] + [ save-user-after ] bi + ] when* ; M: login call-responder* ( path responder -- response ) dup login set + init-user call-next-method ; : ( responder -- responder' ) @@ -359,10 +374,7 @@ M: login call-responder* ( path responder -- response ) ! ! ! Configuration : allow-edit-profile ( login -- login ) - - "edit your profile" >>description - - "edit-profile" add-responder ; + "edit-profile" add-responder ; : allow-registration ( login -- login ) diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 6ddd84a254..cdee2821b6 100644 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -102,14 +102,15 @@ SYMBOL: exit-continuation [ [ "/" ?tail drop "/" ] dip present 3append ] when* ; : a-url ( tag -- url ) - dup "value" optional-attr [ ] [ + dup "value" optional-attr + [ value ] [ swap [ a-url-path >>path ] [ "query" optional-attr parse-query-attr >>query ] bi - ] ?if - adjust-url relative-to-request ; + adjust-url relative-to-request + ] ?if ; CHLOE: atom [ children>string ] [ a-url ] bi add-atom-feed ; diff --git a/extra/http/server/redirection/redirection.factor b/extra/http/server/redirection/redirection.factor index 3cd01345aa..c1d2eaa63a 100644 --- a/extra/http/server/redirection/redirection.factor +++ b/extra/http/server/redirection/redirection.factor @@ -1,10 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors combinators namespaces +USING: kernel accessors combinators namespaces strings logging urls http http.server http.server.responses ; IN: http.server.redirection -: relative-to-request ( url -- url' ) +GENERIC: relative-to-request ( url -- url' ) + +M: string relative-to-request ; + +M: url relative-to-request request get url>> clone f >>query diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 642e9f77f0..376889b46b 100755 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -68,7 +68,7 @@ main-responder global [ <404> or ] change-at [ utf8 [ development-mode get - [ http-error. ] [ drop "Response error" throw ] if + [ http-error. ] [ drop "Response error" rethrow ] if ] with-encoded-output ] recover ] if diff --git a/extra/webapps/blogs/blogs.factor b/extra/webapps/blogs/blogs.factor index 882584f014..100d4226b7 100644 --- a/extra/webapps/blogs/blogs.factor +++ b/extra/webapps/blogs/blogs.factor @@ -1,24 +1,33 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sorting math.order math.parser -urls validators html.components db.types db.tuples calendar -http.server.dispatchers -furnace furnace.actions furnace.auth.login furnace.boilerplate -furnace.sessions furnace.syndication ; +urls validators html.components db db.types db.tuples calendar +present http.server.dispatchers +furnace +furnace.actions +furnace.auth +furnace.auth.login +furnace.boilerplate +furnace.sessions +furnace.syndication ; IN: webapps.blogs TUPLE: blogs < dispatcher ; +SYMBOL: can-administer-blogs? + +can-administer-blogs? define-capability + : view-post-url ( id -- url ) - number>string "$blogs/post/" prepend >url ; + present "$blogs/post/" prepend >url ; : view-comment-url ( parent id -- url ) [ view-post-url ] dip >>anchor ; : list-posts-url ( -- url ) - URL" $blogs/" ; + "$blogs/" >url ; -: user-posts-url ( author -- url ) +: posts-by-url ( author -- url ) "$blogs/by/" prepend >url ; TUPLE: entity id author date content ; @@ -39,7 +48,7 @@ M: entity feed-entry-date date>> ; TUPLE: post < entity title comments ; M: post feed-entry-title - [ author>> ] [ drop ": " ] [ title>> ] tri 3append ; + [ author>> ] [ title>> ] bi ": " swap 3append ; M: post entity-url id>> view-post-url ; @@ -79,19 +88,16 @@ M: comment entity-url [ [ date>> ] compare invert-comparison ] sort ; : validate-author ( -- ) - { { "author" [ [ v-username ] v-optional ] } } validate-params ; + { { "author" [ v-username ] } } validate-params ; : list-posts ( -- posts ) f "author" value >>author - select-tuples [ dup id>> f count-tuples >>comments ] map + select-tuples [ dup id>> f f count-tuples >>comments ] map reverse-chronological-order ; : ( -- action ) - [ - list-posts "posts" set-value - ] >>init - + [ list-posts "posts" set-value ] >>init { blogs "list-posts" } >>template ; : ( -- action ) @@ -100,21 +106,24 @@ M: comment entity-url [ list-posts ] >>entries [ list-posts-url ] >>url ; -: ( -- action ) +: ( -- action ) + "author" >>rest + [ validate-author list-posts "posts" set-value ] >>init - { blogs "user-posts" } >>template ; -: ( -- action ) + { blogs "posts-by" } >>template ; + +: ( -- action ) [ validate-author ] >>init [ "Recent Posts by " "author" value append ] >>title [ list-posts ] >>entries - [ "author" value user-posts-url ] >>url ; + [ "author" value posts-by-url ] >>url ; : ( -- action ) @@ -125,6 +134,7 @@ M: comment entity-url : ( -- action ) + "id" >>rest [ @@ -147,6 +157,7 @@ M: comment entity-url : ( -- action ) + [ validate-post uid "author" set-value @@ -160,40 +171,76 @@ M: comment entity-url [ insert-tuple ] [ entity-url ] bi ] >>submit - { blogs "new-post" } >>template ; + { blogs "new-post" } >>template + + + "make a new blog post" >>description ; + +: authorize-author ( author -- ) + uid = can-administer-blogs? have-capability? or + [ login-required ] unless ; + +: do-post-action ( -- ) + validate-integer-id + "id" value select-tuple from-object ; : ( -- action ) + "id" >>rest - [ - validate-integer-id - "id" value select-tuple from-object - ] >>init + [ do-post-action ] >>init + + [ do-post-action validate-post ] >>validate + + [ "author" value authorize-author ] >>authorize [ - validate-integer-id - validate-post - ] >>validate - - [ - "id" value select-tuple - dup { "title" "content" } deposit-slots + "id" value + dup { "title" "author" "date" "content" } deposit-slots [ update-tuple ] [ entity-url ] bi ] >>submit - { blogs "edit-post" } >>template ; - + { blogs "edit-post" } >>template + + + "edit a blog post" >>description ; + +: delete-post ( id -- ) + [ delete-tuples ] [ f delete-tuples ] bi ; + : ( -- action ) + + [ do-post-action ] >>validate + + [ "author" value authorize-author ] >>authorize + [ - validate-integer-id - { { "author" [ v-username ] } } validate-params - ] >>validate + [ "id" value delete-post ] with-transaction + "author" value posts-by-url + ] >>submit + + + "delete a blog post" >>description ; + +: ( -- action ) + + + [ validate-author ] >>validate + + [ "author" value authorize-author ] >>authorize + [ - "id" value delete-tuples - "author" value user-posts-url - ] >>submit ; + [ + f "author" value >>author select-tuples [ id>> delete-post ] each + f f "author" value >>author delete-tuples + ] with-transaction + "author" value posts-by-url + ] >>submit + + + "delete a blog post" >>description ; : validate-comment ( -- ) { @@ -215,41 +262,44 @@ M: comment entity-url uid >>author now >>date [ insert-tuple ] [ entity-url ] bi - ] >>submit ; - + ] >>submit + + + "make a comment" >>description ; + : ( -- action ) + [ validate-integer-id { { "parent" [ v-integer ] } } validate-params ] >>validate + + [ + "parent" value select-tuple + author>> authorize-author + ] >>authorize + [ f "id" value delete-tuples "parent" value view-post-url - ] >>submit ; - + ] >>submit + + + "delete a comment" >>description ; + : ( -- dispatcher ) blogs new-dispatcher "" add-responder "posts.atom" add-responder - "by" add-responder - "by.atom" add-responder + "by" add-responder + "by.atom" add-responder "post" add-responder "post.atom" add-responder - - "make a new blog post" >>description - "new-post" add-responder - - "edit a blog post" >>description - "edit-post" add-responder - - "delete a blog post" >>description - "delete-post" add-responder - - "make a comment" >>description - "new-comment" add-responder - - "delete a comment" >>description - "delete-comment" add-responder + "new-post" add-responder + "edit-post" add-responder + "delete-post" add-responder + "new-comment" add-responder + "delete-comment" add-responder { blogs "blogs-common" } >>template ; diff --git a/extra/webapps/blogs/user-posts.xml b/extra/webapps/blogs/posts-by.xml similarity index 100% rename from extra/webapps/blogs/user-posts.xml rename to extra/webapps/blogs/posts-by.xml diff --git a/extra/webapps/blogs/view-post.xml b/extra/webapps/blogs/view-post.xml index fae9ff3e76..55bdd2e806 100644 --- a/extra/webapps/blogs/view-post.xml +++ b/extra/webapps/blogs/view-post.xml @@ -33,7 +33,7 @@

- Comment by on : + Comment by on :

diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 2fbe5b4816..f6b604c06d 100644 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -19,6 +19,10 @@ IN: webapps.pastebin TUPLE: pastebin < dispatcher ; +SYMBOL: can-delete-pastes? + +can-delete-pastes? define-capability + ! ! ! ! DOMAIN MODEL ! ! ! @@ -170,13 +174,20 @@ M: annotation entity-url : ( -- action ) + [ validate-integer-id ] >>validate [ - "id" value delete-tuples - "id" value f delete-tuples + [ + "id" value delete-tuples + "id" value f delete-tuples + ] with-transaction URL" $pastebin/list" - ] >>submit ; + ] >>submit + + + "delete pastes" >>description + { can-delete-pastes? } >>capabilities ; ! ! ! ! ANNOTATIONS @@ -199,6 +210,7 @@ M: annotation entity-url : ( -- action ) + [ { { "id" [ v-number ] } } validate-params ] >>validate [ @@ -206,11 +218,11 @@ M: annotation entity-url [ delete-tuples ] [ parent>> paste-url ] bi - ] >>submit ; + ] >>submit -SYMBOL: can-delete-pastes? - -can-delete-pastes? define-capability + + "delete annotations" >>description + { can-delete-pastes? } >>capabilities ; : ( -- responder ) pastebin new-dispatcher @@ -219,13 +231,9 @@ can-delete-pastes? define-capability "paste" add-responder "paste.atom" add-responder "new-paste" add-responder - - "delete pastes" >>description - { can-delete-pastes? } >>capabilities "delete-paste" add-responder + "delete-paste" add-responder "new-annotation" add-responder - - "delete annotations" >>description - { can-delete-pastes? } >>capabilities "delete-annotation" add-responder + "delete-annotation" add-responder { pastebin "pastebin-common" } >>template ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 3e780132b4..888d4bd145 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -18,6 +18,10 @@ IN: webapps.planet TUPLE: planet-factor < dispatcher ; +SYMBOL: can-administer-planet-factor? + +can-administer-planet-factor? define-capability + TUPLE: planet-factor-admin < dispatcher ; TUPLE: blog id name www-url feed-url ; @@ -30,8 +34,8 @@ blog "BLOGS" { { "id" "ID" INTEGER +db-assigned-id+ } { "name" "NAME" { VARCHAR 256 } +not-null+ } - { "www-url" "WWWURL" { VARCHAR 256 } +not-null+ } - { "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ } + { "www-url" "WWWURL" URL +not-null+ } + { "feed-url" "FEEDURL" URL +not-null+ } } define-persistent TUPLE: posting < entry id ; @@ -40,7 +44,7 @@ posting "POSTINGS" { { "id" "ID" INTEGER +db-assigned-id+ } { "title" "TITLE" { VARCHAR 256 } +not-null+ } - { "url" "LINK" { VARCHAR 256 } +not-null+ } + { "url" "LINK" URL +not-null+ } { "description" "DESCRIPTION" TEXT +not-null+ } { "date" "DATE" TIMESTAMP +not-null+ } } define-persistent @@ -134,6 +138,7 @@ posting "POSTINGS" : ( -- action ) + { planet-factor "new-blog" } >>template [ validate-blog ] >>validate @@ -150,9 +155,10 @@ posting "POSTINGS" ] tri ] >>submit ; - + : ( -- action ) + [ validate-integer-id "id" value select-tuple from-object @@ -184,20 +190,16 @@ posting "POSTINGS" "update" add-responder "new-blog" add-responder "edit-blog" add-responder - "delete-blog" add-responder ; - -SYMBOL: can-administer-planet-factor? - -can-administer-planet-factor? define-capability + "delete-blog" add-responder + + "administer Planet Factor" >>description + { can-administer-planet-factor? } >>capabilities ; : ( -- responder ) planet-factor new-dispatcher "list" add-main-responder "feed.xml" add-responder - - "administer Planet Factor" >>description - { can-administer-planet-factor? } >>capabilities - "admin" add-responder + "admin" add-responder { planet-factor "planet-common" } >>template ; diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 4791278974..18130f5144 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -31,6 +31,10 @@ IN: webapps.wiki TUPLE: wiki < dispatcher ; +SYMBOL: can-delete-wiki-articles? + +can-delete-wiki-articles? define-capability + TUPLE: article title revision ; article "ARTICLES" { @@ -81,10 +85,13 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "title" >>rest + [ validate-title ] >>init + [ "title" value dup

select-tuple [ revision>> select-tuple from-object @@ -96,13 +103,16 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "id" >>rest + [ validate-integer-id "id" value select-tuple from-object URL" $wiki/view/" adjust-url present relative-link-prefix set ] >>init + { wiki "view" } >>template ; : add-revision ( revision -- ) @@ -117,14 +127,18 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "title" >>rest + [ validate-title "title" value
select-tuple [ revision>> select-tuple from-object ] when* ] >>init + { wiki "edit" } >>template + [ validate-title { { "content" [ v-required ] } } validate-params @@ -135,7 +149,10 @@ M: revision feed-entry-url id>> revision-url ; logged-in-user get username>> >>author "content" value >>content [ add-revision ] [ title>> view-url ] bi - ] >>submit ; + ] >>submit + + + "edit wiki articles" >>description ; : list-revisions ( -- seq ) f "title" value >>title select-tuples @@ -143,24 +160,34 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "title" >>rest + [ validate-title list-revisions "revisions" set-value ] >>init + { wiki "revisions" } >>template ; : ( -- action ) + "title" >>rest + [ validate-title ] >>init + [ "Revisions of " "title" value append ] >>title + [ "title" value revisions-url ] >>url + [ list-revisions ] >>entries ; : ( -- action ) + [ validate-integer-id ] >>validate + [ "id" value select-tuple clone f >>id [ add-revision ] [ title>> view-url ] bi @@ -183,12 +210,18 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + [ validate-title ] >>validate + [ "title" value
delete-tuples f "title" value >>title delete-tuples URL" $wiki" - ] >>submit ; + ] >>submit + + + "delete wiki articles" >>description + { can-delete-wiki-articles? } >>capabilities ; : ( -- action ) @@ -207,15 +240,18 @@ M: revision feed-entry-url id>> revision-url ; [ [ content>> string-lines ] bi@ diff "diff" set-value ] 2bi ] >>init + { wiki "diff" } >>template ; : ( -- action ) + [ f
select-tuples [ [ title>> ] compare ] sort "articles" set-value ] >>init + { wiki "articles" } >>template ; : list-user-edits ( -- seq ) @@ -224,11 +260,14 @@ M: revision feed-entry-url id>> revision-url ; : ( -- action ) + "author" >>rest + [ validate-author list-user-edits "user-edits" set-value ] >>init + { wiki "user-edits" } >>template ; : ( -- action ) @@ -239,10 +278,6 @@ M: revision feed-entry-url id>> revision-url ; [ "author" value user-edits-url ] >>url [ list-user-edits ] >>entries ; -SYMBOL: can-delete-wiki-articles? - -can-delete-wiki-articles? define-capability - : ( responder -- responder' ) { wiki "page-common" } >>template ; @@ -255,18 +290,13 @@ can-delete-wiki-articles? define-capability "revisions" add-responder "revisions.atom" add-responder "diff" add-responder - - "edit wiki articles" >>description - "edit" add-responder + "edit" add-responder "rollback" add-responder "user-edits" add-responder "articles" add-responder "changes" add-responder "user-edits.atom" add-responder "changes.atom" add-responder - - "delete wiki articles" >>description - { can-delete-wiki-articles? } >>capabilities - "delete" add-responder + "delete" add-responder { wiki "wiki-common" } >>template ; From 7bd7222b07a1d19c26d7eab094f1f5eff369ba4a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 12 Jun 2008 22:51:20 -0700 Subject: [PATCH 017/354] Refactor windows.com.wrapper to make better use of fry and cleave to show what is going on. Create named words for wrapper alien-callbacks so it is easy to see what code gets generated. Change com-query-interface to malloc the buffer for the returned interface pointer to avoid GC heisenbugs when calling into a com-wrapped factor object --- extra/windows/com/com.factor | 8 +- extra/windows/com/wrapper/wrapper.factor | 110 ++++++++++++++--------- 2 files changed, 74 insertions(+), 44 deletions(-) mode change 100644 => 100755 extra/windows/com/com.factor diff --git a/extra/windows/com/com.factor b/extra/windows/com/com.factor old mode 100644 new mode 100755 index 4833a7412a..4202ed4c56 --- a/extra/windows/com/com.factor +++ b/extra/windows/com/com.factor @@ -1,5 +1,5 @@ USING: alien alien.c-types windows.com.syntax windows.ole32 -windows.types continuations kernel alien.syntax ; +windows.types continuations kernel alien.syntax libc ; IN: windows.com LIBRARY: ole32 @@ -27,9 +27,9 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ; : com-query-interface ( interface iid -- interface' ) - f - [ IUnknown::QueryInterface ole32-error ] keep - *void* ; + "void*" heap-size [ + [ IUnknown::QueryInterface ole32-error ] keep *void* + ] with-malloc ; : com-add-ref ( interface -- interface ) [ IUnknown::AddRef drop ] keep ; inline diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 972a75ecb9..6d6aa078e8 100755 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -1,11 +1,12 @@ USING: alien alien.c-types windows.com.syntax windows.com.syntax.private windows.com continuations kernel -sequences.lib namespaces windows.ole32 libc +sequences.lib namespaces windows.ole32 libc vocabs assocs accessors arrays sequences quotations combinators -math combinators.lib words compiler.units destructors ; +math combinators.lib words compiler.units destructors fry +math.parser ; IN: windows.com.wrapper -TUPLE: com-wrapper vtbls freed? ; +TUPLE: com-wrapper vtbls disposed ; byte-array ] % + [ find-com-interface-definition family-tree [ iid>> ] map ] dip + 1quotation [ 2array ] curry map + ] map-index concat + [ drop f ] suffix ; + +: (make-query-interface) ( interfaces -- quot ) + (query-interface-cases) + '[ + swap 16 memory>byte-array + , case [ - >r find-com-interface-definition family-tree - r> 1quotation [ >r iid>> r> 2array ] curry map - ] map-index concat - [ drop f ] suffix , - \ case , - "void*" heap-size - [ * rot com-add-ref 0 rot set-void*-nth S_OK ] - curry , - [ nip f 0 rot set-void*-nth E_NOINTERFACE ] , - \ if* , - ] [ ] make ; + "void*" heap-size * rot com-add-ref + 0 rot set-void*-nth S_OK + ] [ nip f 0 rot set-void*-nth E_NOINTERFACE ] if* + ] ; : (make-add-ref) ( interfaces -- quot ) - length "void*" heap-size * [ swap + length "void*" heap-size * '[ + , swap 0 over ulong-nth 1+ [ 0 rot set-ulong-nth ] keep - ] curry ; + ] ; : (make-release) ( interfaces -- quot ) - length "void*" heap-size * [ over + length "void*" heap-size * '[ + , over 0 over ulong-nth 1- [ 0 rot set-ulong-nth ] keep dup zero? [ swap (free-wrapped-object) ] [ nip ] if - ] curry ; + ] ; : (make-iunknown-methods) ( interfaces -- quots ) [ (make-query-interface) ] @@ -60,32 +75,48 @@ unless : (thunk) ( n -- quot ) dup 0 = [ drop [ ] ] - [ "void*" heap-size neg * [ swap ] curry ] + [ "void*" heap-size neg * '[ , swap ] ] if ; -: (thunked-quots) ( quots iunknown-methods thunk -- quots' ) - [ [ swap 2array ] curry map swap ] keep - [ com-unwrap ] compose [ swap 2array ] curry map append ; +: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s ) + [ '[ , '[ @ com-unwrap ] [ swap 2array ] curry map ] ] + [ '[ , [ swap 2array ] curry map ] ] bi bi* + swap append ; -: compile-alien-callback ( return parameters abi quot -- alien ) +: compile-alien-callback ( word return parameters abi quot -- alien ) [ alien-callback ] 4 ncurry - [ gensym [ swap (( -- alien )) define-declared ] keep ] + [ [ (( -- alien )) define-declared ] pick slip ] with-compilation-unit execute ; -: (make-vtbl) ( interface-name quots iunknown-methods n -- ) +: (byte-array-to-malloced-buffer) ( byte-array -- alien ) + [ byte-length malloc ] [ over byte-array>memory ] bi ; + +: (callback-word) ( function-name interface-name counter -- word ) + [ "::" rot 3append "-callback-" ] dip number>string 3append + "windows.com.wrapper.callbacks" create ; + +: (finish-thunk) ( param-count thunk quot -- thunked-quot ) + [ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ] + dip compose ; + +: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl ) (thunk) (thunked-quots) - swap find-com-interface-definition family-tree-functions [ - [ return>> ] [ parameters>> [ first ] map ] bi - dup length 1- roll [ - first dup empty? - [ 2drop [ ] ] - [ swap [ ndip ] 2curry ] - if - ] [ second ] bi compose + swap [ find-com-interface-definition family-tree-functions ] + keep (next-vtbl-counter) '[ + swap [ + [ name>> , , (callback-word) ] + [ return>> ] [ + parameters>> + [ [ first ] map ] + [ length ] bi + ] tri + ] [ + first2 (finish-thunk) + ] bi* "stdcall" swap compile-alien-callback - ] 2map >c-void*-array [ byte-length malloc ] keep - over byte-array>memory ; + ] 2map >c-void*-array + (byte-array-to-malloced-buffer) ; : (make-vtbls) ( implementations -- vtbls ) dup [ first ] map (make-iunknown-methods) @@ -102,11 +133,10 @@ PRIVATE> : ( implementations -- wrapper ) (make-vtbls) f com-wrapper boa ; -M: com-wrapper dispose - t >>freed? +M: com-wrapper dispose* vtbls>> [ free ] each ; : com-wrap ( object wrapper -- wrapped-object ) - dup (malloc-wrapped-object) >r vtbls>> r> + [ vtbls>> ] [ (malloc-wrapped-object) ] bi [ [ set-void*-nth ] curry each-index ] keep [ +wrapped-objects+ get-global set-at ] keep ; From f508f57fa06aed9e6bd58aaf471a2ecbc828d19c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 13 Jun 2008 01:17:10 -0500 Subject: [PATCH 018/354] add create-index --- extra/db/queries/queries.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/extra/db/queries/queries.factor b/extra/db/queries/queries.factor index 807aeda74a..5c3f3e13e6 100644 --- a/extra/db/queries/queries.factor +++ b/extra/db/queries/queries.factor @@ -195,3 +195,12 @@ M: db ( tuple class groups -- statement ) ] { { } { } { } } nmake >r >r parse-sql 4drop r> r> maybe-make-retryable do-select ; + +: create-index ( index-name table-name columns -- ) + [ + >r >r "create index " % % r> " on " % % r> "(" % + "," join % ")" % + ] "" make sql-command ; + +: drop-index ( index-name -- ) + [ "drop index " % % ] "" make sql-command ; From 045b657474f819a63243bd4c412f5ea93ea3119a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Jun 2008 01:51:46 -0500 Subject: [PATCH 019/354] Move replicate into core; move selection sort into its own vocab; remove usages of and? and or? which are redundant now --- core/bit-arrays/bit-arrays-tests.factor | 2 +- core/classes/algebra/algebra-tests.factor | 6 +++--- core/inference/backend/backend.factor | 6 +++--- core/sequences/sequences.factor | 6 ++++++ core/sorting/sorting-tests.factor | 2 +- core/strings/strings-tests.factor | 2 +- core/vectors/vectors-tests.factor | 2 +- extra/color-picker/color-picker.factor | 2 +- extra/delegate/delegate.factor | 14 +++++++++++--- extra/io/files/unique/unique.factor | 2 +- extra/io/pipes/pipes.factor | 2 +- extra/koszul/koszul.factor | 2 +- extra/lcs/lcs-tests.factor | 4 ++++ extra/lcs/lcs.factor | 12 ++++++++---- extra/project-euler/150/150.factor | 5 +---- extra/sequences/lib/lib.factor | 18 ------------------ extra/sorting/insertion/authors.txt | 1 + extra/sorting/insertion/insertion.factor | 16 ++++++++++++++++ extra/sorting/insertion/summary.txt | 1 + extra/sorting/insertion/tags.txt | 1 + extra/state-parser/state-parser.factor | 2 +- extra/strings/lib/lib-tests.factor | 2 +- extra/strings/lib/lib.factor | 3 +-- extra/ui/gadgets/frames/frames.factor | 2 +- extra/unicode/breaks/breaks.factor | 5 ++--- extra/unicode/collation/collation.factor | 3 +-- extra/unicode/data/data.factor | 4 ++-- extra/unicode/normalize/normalize.factor | 2 +- extra/webapps/wee-url/wee-url.factor | 2 +- 29 files changed, 74 insertions(+), 57 deletions(-) create mode 100644 extra/sorting/insertion/authors.txt create mode 100644 extra/sorting/insertion/insertion.factor create mode 100644 extra/sorting/insertion/summary.txt create mode 100644 extra/sorting/insertion/tags.txt diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index 03961c2db6..b41cf9c4a5 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -38,7 +38,7 @@ IN: bit-arrays.tests [ t ] [ 100 [ - drop 100 [ drop 2 random zero? ] map + drop 100 [ 2 random zero? ] replicate dup >bit-array >array = ] all? ] unit-test diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 28e899d08b..05c254f225 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -204,7 +204,7 @@ UNION: z1 b1 c1 ; 10 [ [ ] [ - 20 [ drop random-op ] map >quotation + 20 [ random-op ] [ ] replicate-as [ infer effect-in [ random-class ] times ] keep call drop @@ -238,8 +238,8 @@ UNION: z1 b1 c1 ; 20 [ [ t ] [ - 20 [ drop random-boolean-op ] [ ] map-as dup . - [ infer effect-in [ drop random-boolean ] map dup . ] keep + 20 [ random-boolean-op ] [ ] replicate-as dup . + [ infer effect-in [ random-boolean ] replicate dup . ] keep [ >r [ ] each r> call ] 2keep diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 8966a38496..f8b071e803 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -80,7 +80,7 @@ M: object value-literal \ literal-expected inference-warning ; 1 #drop node, pop-d dup value-literal >r value-recursion r> ; -: value-vector ( n -- vector ) [ drop ] V{ } map-as ; +: value-vector ( n -- vector ) [ ] V{ } replicate-as ; : add-inputs ( seq stack -- n stack ) tuck [ length ] bi@ - dup 0 > @@ -162,7 +162,7 @@ TUPLE: too-many-r> ; dup ensure-values #>r over 0 pick node-inputs - over [ drop pop-d ] map reverse [ push-r ] each + over [ pop-d ] replicate reverse [ push-r ] each 0 pick pick node-outputs node, drop ; @@ -171,7 +171,7 @@ TUPLE: too-many-r> ; dup check-r> #r> 0 pick pick node-inputs - over [ drop pop-r ] map reverse [ push-d ] each + over [ pop-r ] replicate reverse [ push-d ] each over 0 pick node-outputs node, drop ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 4854ff8001..cb33552693 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -361,6 +361,12 @@ PRIVATE> : map ( seq quot -- newseq ) over map-as ; inline +: replicate ( seq quot -- newseq ) + [ drop ] prepose map ; inline + +: replicate-as ( seq quot exemplar -- newseq ) + >r [ drop ] prepose r> map-as ; inline + : change-each ( seq quot -- ) over map-into ; inline diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor index a56c41b620..17ec2d7cd1 100755 --- a/core/sorting/sorting-tests.factor +++ b/core/sorting/sorting-tests.factor @@ -11,7 +11,7 @@ unit-test [ t ] [ 100 [ drop - 100 [ drop 20 random [ drop 1000 random ] map ] map natural-sort [ before=? ] monotonic? + 100 [ 20 random [ 1000 random ] replicate ] replicate natural-sort [ before=? ] monotonic? ] all? ] unit-test diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 44e1d8859f..d10f1603f1 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -98,7 +98,7 @@ unit-test [ ] [ [ 4 [ - 100 [ drop "obdurak" clone ] map + 100 [ "obdurak" clone ] replicate gc dup [ 1234 0 rot set-string-nth diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 8f64265771..7f4abe3222 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -26,7 +26,7 @@ IN: vectors.tests [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test [ t ] [ - 100 [ drop 100 random ] map >vector + 100 [ 100 random ] V{ } map-as dup >array >vector = ] unit-test diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 0480235dfe..c64d1e4872 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -24,7 +24,7 @@ M: color-preview model-changed [ [ 256 /f ] map 1 suffix ] ; : ( -- model gadget ) - 3 [ drop 0 0 0 255 ] map + 3 [ 0 0 0 255 ] replicate dup [ range-model ] map swap [ [ gadget, ] each ] make-filled-pile ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index c375dcf874..4f1e950b01 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: parser generic kernel classes words slots assocs -sequences arrays vectors definitions prettyprint combinators.lib -math hashtables sets ; +sequences arrays vectors definitions prettyprint +math hashtables sets macros namespaces ; IN: delegate : protocol-words ( protocol -- words ) @@ -23,7 +23,15 @@ M: tuple-class group-words : consult-method ( word class quot -- ) [ drop swap first create-method ] - [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi + [ + nip + [ + over second saver % + % + dup second restorer % + first , + ] [ ] make + ] 3bi define ; : change-word-prop ( word prop quot -- ) diff --git a/extra/io/files/unique/unique.factor b/extra/io/files/unique/unique.factor index 06a3ec8dd2..3efef66ae3 100644 --- a/extra/io/files/unique/unique.factor +++ b/extra/io/files/unique/unique.factor @@ -15,7 +15,7 @@ IN: io.files.unique [ 10 random CHAR: 0 + ] [ random-letter ] if ; : random-name ( n -- string ) - [ drop random-ch ] "" map-as ; + [ random-ch ] "" replicate-as ; : unique-length ( -- n ) 10 ; inline : unique-retries ( -- n ) 10 ; inline diff --git a/extra/io/pipes/pipes.factor b/extra/io/pipes/pipes.factor index b519752e79..72beb473ed 100644 --- a/extra/io/pipes/pipes.factor +++ b/extra/io/pipes/pipes.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.encodings io.backend io.ports io.streams.duplex -io splitting grouping sequences sequences.lib namespaces kernel +io splitting grouping sequences namespaces kernel destructors math concurrency.combinators accessors arrays continuations quotations ; IN: io.pipes diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 7b636609b0..b56473a0a9 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -142,7 +142,7 @@ DEFER: (d) ! Computing a basis : graded ( seq -- seq ) - dup 0 [ length max ] reduce 1+ [ drop V{ } clone ] map + dup 0 [ length max ] reduce 1+ [ V{ } clone ] replicate [ dup length pick nth push ] reduce ; : nth-basis-elt ( generators n -- elt ) diff --git a/extra/lcs/lcs-tests.factor b/extra/lcs/lcs-tests.factor index 3aa10a0687..7d9a9ffd27 100755 --- a/extra/lcs/lcs-tests.factor +++ b/extra/lcs/lcs-tests.factor @@ -2,6 +2,10 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test lcs ; +\ lcs must-infer +\ diff must-infer +\ levenshtein must-infer + [ 3 ] [ "sitting" "kitten" levenshtein ] unit-test [ 3 ] [ "kitten" "sitting" levenshtein ] unit-test [ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test diff --git a/extra/lcs/lcs.factor b/extra/lcs/lcs.factor index 06c33505ca..4b0fb53f5e 100755 --- a/extra/lcs/lcs.factor +++ b/extra/lcs/lcs.factor @@ -63,15 +63,19 @@ TUPLE: trace-state old new table i j ; [ 1- ] change-i [ 1- ] change-j ; : inserted? ( state -- ? ) - [ j>> 0 > ] - [ [ i>> zero? ] [ top-beats-side? ] or? ] and? ; + { + [ j>> 0 > ] + [ { [ i>> zero? ] [ top-beats-side? ] } 1|| ] + } 1&& ; : do-insert ( state -- state ) dup new-nth insert boa , [ 1- ] change-j ; : deleted? ( state -- ? ) - [ i>> 0 > ] - [ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ; + { + [ i>> 0 > ] + [ { [ j>> zero? ] [ top-beats-side? not ] } 1|| ] + } 1&& ; : do-delete ( state -- state ) dup old-nth delete boa , [ 1- ] change-i ; diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 8c93d4f7e6..49de5dbc03 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -17,9 +17,6 @@ IN: project-euler.150 : partial-sum-infimum ( seq -- seq ) 0 0 rot [ (partial-sum-infimum) ] each drop ; inline -: generate ( n quot -- seq ) - [ drop ] prepose map ; inline - : map-infimum ( seq quot -- min ) [ min ] compose 0 swap reduce ; inline @@ -30,7 +27,7 @@ IN: project-euler.150 615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline : sums-triangle ( -- seq ) - 0 1000 [ 1+ [ next ] generate partial-sums ] map nip ; + 0 1000 [ 1+ [ next ] replicate partial-sums ] map nip ; PRIVATE> diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 265cd5b592..ed4c337a92 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -131,10 +131,6 @@ MACRO: firstn ( n -- ) [ find drop [ head-slice ] when* ] curry [ dup ] prepose keep like ; -: replicate ( seq quot -- newseq ) - #! quot: ( -- obj ) - [ drop ] prepose map ; inline - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : short ( seq n -- seq n' ) over length min ; inline -= [ - n n 1- seq exchange - seq quot n 1- insert - ] unless - ] unless ; inline -PRIVATE> - -: insertion-sort ( seq quot -- ) - ! quot is a transformation on elements - over length [ insert ] 2with each ; inline - : if-seq ( seq quot1 quot2 -- ) [ f like ] 2dip if* ; inline diff --git a/extra/sorting/insertion/authors.txt b/extra/sorting/insertion/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/sorting/insertion/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/sorting/insertion/insertion.factor b/extra/sorting/insertion/insertion.factor new file mode 100644 index 0000000000..3a46eb83fd --- /dev/null +++ b/extra/sorting/insertion/insertion.factor @@ -0,0 +1,16 @@ +USING: locals sequences kernel math ; +IN: sorting.insertion + += [ + n n 1- seq exchange + seq quot n 1- insert + ] unless + ] unless ; inline +PRIVATE> + +: insertion-sort ( seq quot -- ) + ! quot is a transformation on elements + over length [ insert ] with with each ; inline diff --git a/extra/sorting/insertion/summary.txt b/extra/sorting/insertion/summary.txt new file mode 100644 index 0000000000..a71be797d9 --- /dev/null +++ b/extra/sorting/insertion/summary.txt @@ -0,0 +1 @@ +Insertion sort diff --git a/extra/sorting/insertion/tags.txt b/extra/sorting/insertion/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/sorting/insertion/tags.txt @@ -0,0 +1 @@ +collections diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index af005b4abe..1feaf46017 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -144,7 +144,7 @@ M: not-enough-characters summary ( obj -- str ) ] if next ; : expect-string ( string -- ) - dup [ drop get-char next ] map 2dup = + dup [ get-char next ] replicate 2dup = [ 2drop ] [ expected ] if ; : init-parser ( -- ) diff --git a/extra/strings/lib/lib-tests.factor b/extra/strings/lib/lib-tests.factor index 2779e190c9..6e0ce05eaa 100644 --- a/extra/strings/lib/lib-tests.factor +++ b/extra/strings/lib/lib-tests.factor @@ -5,4 +5,4 @@ IN: temporary [ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ upper-alpha-chars "" like ] unit-test [ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" ] [ alpha-chars "" like ] unit-test [ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" ] [ alphanumeric-chars "" like ] unit-test -[ t ] [ 100 [ drop random-alphanumeric-char ] map alphanumeric-chars [ member? ] curry all? ] unit-test +[ t ] [ 100 [ random-alphanumeric-char ] replicate alphanumeric-chars [ member? ] curry all? ] unit-test diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index e1d88e479d..6ecca05ec8 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -30,5 +30,4 @@ IN: strings.lib alphanumeric-chars random ; : random-alphanumeric-string ( length -- str ) - [ drop random-alphanumeric-char ] map "" like ; - + [ random-alphanumeric-char ] "" replicate-as ; diff --git a/extra/ui/gadgets/frames/frames.factor b/extra/ui/gadgets/frames/frames.factor index 3e38f60627..c0fe59a529 100644 --- a/extra/ui/gadgets/frames/frames.factor +++ b/extra/ui/gadgets/frames/frames.factor @@ -8,7 +8,7 @@ IN: ui.gadgets.frames ! gadgets gets left-over space. TUPLE: frame ; -: ( -- grid ) 9 [ drop ] map 3 group ; +: ( -- grid ) 9 [ ] replicate 3 group ; : @center 1 1 ; : @left 0 1 ; diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 23dfc16e78..b70d79b872 100755 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -23,8 +23,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; CATEGORY: (extend) Me Mn ; : extend? ( ch -- ? ) - [ (extend)? ] - [ "Other_Grapheme_Extend" property? ] or? ; + { [ (extend)? ] [ "Other_Grapheme_Extend" property? ] } 1|| ; : grapheme-class ( ch -- class ) { @@ -35,7 +34,7 @@ CATEGORY: (extend) Me Mn ; } cond ; : init-grapheme-table ( -- table ) - graphemes [ drop graphemes f ] map ; + graphemes [ graphemes f ] replicate ; SYMBOL: table diff --git a/extra/unicode/collation/collation.factor b/extra/unicode/collation/collation.factor index f71a58be85..216f80c79d 100755 --- a/extra/unicode/collation/collation.factor +++ b/extra/unicode/collation/collation.factor @@ -58,8 +58,7 @@ ducet insert-helpers HEX: 7FFF bitand HEX: 8000 bitor 0 0 f weight boa ; : illegal? ( char -- ? ) - [ "Noncharacter_Code_Point" property? ] - [ category "Cs" = ] or? ; + { [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ; : derive-weight ( char -- weights ) first dup illegal? diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index e3dd15558b..8ef8658adb 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -62,7 +62,7 @@ VALUE: properties dup [ swap (chain-decomposed) ] curry assoc-map ; : first* ( seq -- ? ) - second [ empty? ] [ first ] or? ; + second { [ empty? ] [ first ] } 1|| ; : (process-decomposed) ( data -- alist ) 5 swap (process-data) @@ -107,7 +107,7 @@ VALUE: properties :: fill-ranges ( table -- table ) name-map >alist sort-values keys - [ [ "first>" tail? ] [ "last>" tail? ] or? ] filter + [ { [ "first>" tail? ] [ "last>" tail? ] } 1|| ] filter 2 group [ [ name>char ] bi@ [ [a,b] ] [ table ?nth ] bi [ swap table ?set-nth ] curry each diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index 576c5a7e20..3b64cf577f 100755 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -1,5 +1,5 @@ USING: sequences namespaces unicode.data kernel math arrays -locals combinators.lib sequences.lib combinators.lib ; +locals combinators.lib sorting.insertion combinators.lib ; IN: unicode.normalize ! Conjoining Jamo behavior diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index afdacf9add..d408c645f3 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -26,7 +26,7 @@ short-url "SHORT_URLS" { 3append ; foldable : random-url ( -- string ) - 1 6 [a,b] random [ drop letter-bank random ] "" map-as ; + 1 6 [a,b] random [ letter-bank random ] "" replicate-as ; : insert-short-url ( short-url -- short-url ) '[ , dup random-url >>short insert-tuple ] 10 retry ; From 375020b7fe9d46bc9831a4f8790e5c3ae59be4be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Jun 2008 02:09:16 -0500 Subject: [PATCH 020/354] Add push-at to core --- core/assocs/assocs.factor | 3 +++ core/optimizer/def-use/def-use.factor | 5 ++--- extra/assocs/lib/lib.factor | 5 +---- extra/gap-buffer/cursortree/cursortree.factor | 4 ++-- extra/help/lint/lint.factor | 2 +- extra/io/unix/backend/backend.factor | 7 ++----- extra/unicode/data/data.factor | 4 ++-- extra/xmode/rules/rules.factor | 2 +- 8 files changed, 14 insertions(+), 18 deletions(-) diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor index ca49b550b0..c875475278 100755 --- a/core/assocs/assocs.factor +++ b/core/assocs/assocs.factor @@ -150,6 +150,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) : value-at ( value assoc -- key/f ) swap [ = nip ] curry assoc-find 2drop ; +: push-at ( value key assoc -- ) + [ ?push ] change-at ; + : zip ( keys values -- alist ) 2array flip ; inline diff --git a/core/optimizer/def-use/def-use.factor b/core/optimizer/def-use/def-use.factor index a2e9f88135..d4905a1718 100755 --- a/core/optimizer/def-use/def-use.factor +++ b/core/optimizer/def-use/def-use.factor @@ -13,7 +13,7 @@ SYMBOL: def-use used-by empty? ; : uses-values ( node seq -- ) - [ def-use get [ ?push ] change-at ] with each ; + [ def-use get push-at ] with each ; : defs-values ( seq -- ) #! If there is no value, set it to a new empty vector, @@ -132,5 +132,4 @@ M: #r> kill-node* #! degree of accuracy; the new values should be marked as #! having _some_ usage, so that flushing doesn't erronously #! flush them away. - nest-def-use keys - def-use get [ [ t swap ?push ] change-at ] curry each ; + nest-def-use keys def-use get [ t -rot push-at ] curry each ; diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index c3e487a9fc..1c89c1eb16 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -17,9 +17,6 @@ IN: assocs.lib : replace-at ( assoc value key -- assoc ) >r >r dup r> 1vector r> rot set-at ; -: insert-at ( value key assoc -- ) - [ ?push ] change-at ; - : peek-at* ( assoc key -- obj ? ) swap at* dup [ >r peek r> ] when ; @@ -32,7 +29,7 @@ IN: assocs.lib : multi-assoc-each ( assoc quot -- ) [ with each ] curry assoc-each ; inline -: insert ( value variable -- ) namespace insert-at ; +: insert ( value variable -- ) namespace push-at ; : generate-key ( assoc -- str ) >r 32 random-bits >hex r> diff --git a/extra/gap-buffer/cursortree/cursortree.factor b/extra/gap-buffer/cursortree/cursortree.factor index a3a5075820..4249aea2d9 100644 --- a/extra/gap-buffer/cursortree/cursortree.factor +++ b/extra/gap-buffer/cursortree/cursortree.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs assocs.lib kernel gap-buffer generic trees trees.avl math +USING: assocs kernel gap-buffer generic trees trees.avl math sequences quotations ; IN: gap-buffer.cursortree @@ -21,7 +21,7 @@ TUPLE: right-cursor ; : cursor-index ( cursor -- i ) cursor-i ; -: add-cursor ( cursortree cursor -- ) dup cursor-index rot insert-at ; +: add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ; : remove-cursor ( cursortree cursor -- ) tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ; diff --git a/extra/help/lint/lint.factor b/extra/help/lint/lint.factor index 00a8e287e6..eef2463019 100755 --- a/extra/help/lint/lint.factor +++ b/extra/help/lint/lint.factor @@ -114,7 +114,7 @@ M: help-error error. H{ } clone [ [ >r >r dup >link where dup - [ first r> at r> [ ?push ] change-at ] + [ first r> at r> push-at ] [ r> r> 2drop 2drop ] if ] 2curry each diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 67856a0570..8e76be2632 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -44,14 +44,11 @@ TUPLE: mx fd reads writes ; GENERIC: add-input-callback ( thread fd mx -- ) -: add-callback ( thread fd assoc -- ) - [ ?push ] change-at ; - -M: mx add-input-callback reads>> add-callback ; +M: mx add-input-callback reads>> push-at ; GENERIC: add-output-callback ( thread fd mx -- ) -M: mx add-output-callback writes>> add-callback ; +M: mx add-output-callback writes>> push-at ; GENERIC: remove-input-callbacks ( fd mx -- callbacks ) diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 8ef8658adb..5fb769e499 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,7 +1,7 @@ USING: assocs math kernel sequences io.files hashtables quotations splitting grouping arrays math.parser hash2 math.order byte-arrays words namespaces words compiler.units parser -io.encodings.ascii values interval-maps ascii sets assocs.lib +io.encodings.ascii values interval-maps ascii sets combinators.lib combinators locals math.ranges sorting ; IN: unicode.data @@ -151,7 +151,7 @@ C: code-point : properties>intervals ( properties -- assoc[str,interval] ) dup values prune [ f ] H{ } map>assoc - [ [ insert-at ] curry assoc-each ] keep + [ [ push-at ] curry assoc-each ] keep [ ] assoc-map ; : load-properties ( -- assoc ) diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor index df5580fc68..daaeac70a4 100755 --- a/extra/xmode/rules/rules.factor +++ b/extra/xmode/rules/rules.factor @@ -42,7 +42,7 @@ MEMO: standard-rule-set ( id -- ruleset ) rule-set-imports push ; : inverted-index ( hashes key index -- ) - [ swapd [ ?push ] change-at ] 2curry each ; + [ swapd push-at ] 2curry each ; : ?push-all ( seq1 seq2 -- seq1+seq2 ) [ From fbd799f0a201246b2fbf6a98839a569d3f0b5f3c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Jun 2008 02:14:35 -0500 Subject: [PATCH 021/354] Fix test failures --- extra/html/templates/chloe/chloe-tests.factor | 2 +- extra/io/server/server-tests.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/html/templates/chloe/chloe-tests.factor b/extra/html/templates/chloe/chloe-tests.factor index 6ca596f503..433aedbc9a 100644 --- a/extra/html/templates/chloe/chloe-tests.factor +++ b/extra/html/templates/chloe/chloe-tests.factor @@ -151,7 +151,7 @@ TUPLE: person first-name last-name ; [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test -[ "
" ] [ +[ "
" ] [ [ "test10" test-template call-template ] run-template diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor index 86cfe35bc1..965a70718b 100755 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -2,6 +2,6 @@ IN: io.server.tests USING: tools.test io.server io.server.private kernel ; { 2 0 } [ [ ] server-loop ] must-infer-as -{ 2 0 } [ [ ] with-connection ] must-infer-as +{ 3 0 } [ [ ] with-connection ] must-infer-as { 1 0 } [ [ ] swap datagram-loop ] must-infer-as { 2 0 } [ [ ] with-datagrams ] must-infer-as From 3fa97aa1716d43a5a5a9974ad83927a6e242d452 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 13 Jun 2008 03:40:51 -0500 Subject: [PATCH 022/354] combinators.lib: remove old words --- extra/combinators/lib/lib.factor | 26 -------------------------- 1 file changed, 26 deletions(-) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index da13901ab7..fe6b68638b 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -66,32 +66,6 @@ MACRO: napply ( n -- ) : short-circuit ( quots quot default -- quot ) 1quotation -rot { } map>assoc alist>quot ; -! MACRO: && ( quots -- ? ) -! [ [ not ] append [ f ] ] t short-circuit ; - -! MACRO: <-&& ( quots -- ) -! [ [ dup ] prepend [ not ] append [ f ] ] t short-circuit -! [ nip ] append ; - -! MACRO: <--&& ( quots -- ) -! [ [ 2dup ] prepend [ not ] append [ f ] ] t short-circuit -! [ 2nip ] append ; - -! or - -! MACRO: || ( quots -- ? ) [ [ t ] ] f short-circuit ; - -! MACRO: 0|| ( quots -- ? ) [ [ t ] ] f short-circuit ; - -! MACRO: 1|| ( quots -- ? ) -! [ [ dup ] prepend [ t ] ] f short-circuit [ nip ] append ; - -! MACRO: 2|| ( quots -- ? ) -! [ [ 2dup ] prepend [ t ] ] f short-circuit [ 2nip ] append ; - -! MACRO: 3|| ( quots -- ? ) -! [ [ 3dup ] prepend [ t ] ] f short-circuit [ 3nip ] append ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MACRO: 0&& ( quots -- quot ) From 01c3a185b85c138397a9e29fefc4ee2dd21847b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Jun 2008 15:35:40 -0500 Subject: [PATCH 023/354] Fixing tests --- core/vectors/vectors-tests.factor | 2 +- extra/sequences/lib/lib-tests.factor | 1 - extra/sorting/insertion/insertion-tests.factor | 4 ++++ 3 files changed, 5 insertions(+), 2 deletions(-) create mode 100644 extra/sorting/insertion/insertion-tests.factor diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 7f4abe3222..3b2c94b2e5 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -26,7 +26,7 @@ IN: vectors.tests [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test [ t ] [ - 100 [ 100 random ] V{ } map-as + 100 [ 100 random ] V{ } replicate-as dup >array >vector = ] unit-test diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index ee447decdf..019796c1a1 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -80,7 +80,6 @@ IN: sequences.lib.tests [ ] [ { } 0 firstn ] unit-test [ "a" ] [ { "a" } 1 firstn ] unit-test -[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test [ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test [ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test diff --git a/extra/sorting/insertion/insertion-tests.factor b/extra/sorting/insertion/insertion-tests.factor new file mode 100644 index 0000000000..38b0082ade --- /dev/null +++ b/extra/sorting/insertion/insertion-tests.factor @@ -0,0 +1,4 @@ +IN: sorting.insertion +USING: sorting.insertion sequences kernel tools.test ; + +[ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test From a949c1038745f34e43716e52d69f7b588bc8bfcd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Jun 2008 20:54:31 -0500 Subject: [PATCH 024/354] Minor DB cleanup, add an ensure-tables word --- extra/db/sqlite/sqlite.factor | 2 +- extra/db/tuples/tuples.factor | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c7c9065b43..38a3899fc4 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -53,7 +53,7 @@ M: sqlite-result-set dispose ( result-set -- ) M: sqlite-statement low-level-bind ( statement -- ) [ statement-bind-params ] [ statement-handle ] bi - swap [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ; + [ swap [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] curry each ; M: sqlite-statement bind-statement* ( statement -- ) sqlite-maybe-prepare diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 4903adff5c..e02e21cbe6 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -122,6 +122,9 @@ M: retryable execute-statement* ( statement type -- ) : ensure-table ( class -- ) [ create-table ] curry ignore-errors ; +: ensure-tables ( classes -- ) + [ ensure-table ] each ; + : insert-db-assigned-statement ( tuple -- ) dup class db get db-insert-statements [ ] cache From e7b786ecfa9ea6448df3d1ee747cb3d2d21a6df6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 13 Jun 2008 20:54:52 -0500 Subject: [PATCH 025/354] New furnace.alloy vocab makes things easier; add expiration for asides and flash scopes --- extra/furnace/alloy/alloy.factor | 24 +++++++ extra/furnace/asides/asides.factor | 64 +++++++++++++------ .../furnace/auth/providers/db/db-tests.factor | 2 +- extra/furnace/auth/providers/db/db.factor | 2 - extra/furnace/cache/cache.factor | 36 +++++++++++ extra/furnace/flash/flash.factor | 53 ++++++++++----- extra/furnace/sessions/sessions-tests.factor | 4 +- extra/furnace/sessions/sessions.factor | 34 +++------- extra/http/http-tests.factor | 8 +-- extra/http/server/server.factor | 4 +- .../persistent-vectors-tests.factor | 2 +- extra/webapps/blogs/blogs.factor | 4 -- .../factor-website/factor-website.factor | 34 ++++------ extra/webapps/pastebin/pastebin.factor | 4 -- extra/webapps/planet/planet.factor | 4 -- extra/webapps/todo/todo.factor | 2 - extra/webapps/wee-url/wee-url.factor | 3 - extra/webapps/wiki/wiki.factor | 4 -- 18 files changed, 171 insertions(+), 117 deletions(-) create mode 100644 extra/furnace/alloy/alloy.factor create mode 100644 extra/furnace/cache/cache.factor diff --git a/extra/furnace/alloy/alloy.factor b/extra/furnace/alloy/alloy.factor new file mode 100644 index 0000000000..24b47cc4b8 --- /dev/null +++ b/extra/furnace/alloy/alloy.factor @@ -0,0 +1,24 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences db.tuples alarms calendar db fry +furnace.cache +furnace.asides +furnace.flash +furnace.sessions +furnace.db +furnace.auth.providers ; +IN: furnace.alloy + +: ( responder db params -- responder' ) + [ ] 2dip ; + +: state-classes { session flash-scope aside } ; inline + +: init-furnace-tables ( -- ) + state-classes ensure-tables + user ensure-table ; + +: start-expiring ( db params -- ) + '[ + , , [ state-classes [ expire-state ] each ] with-db + ] 5 minutes every drop ; diff --git a/extra/furnace/asides/asides.factor b/extra/furnace/asides/asides.factor index f6b4e2c15f..fc767e050d 100644 --- a/extra/furnace/asides/asides.factor +++ b/extra/furnace/asides/asides.factor @@ -2,37 +2,60 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors namespaces sequences arrays kernel assocs assocs.lib hashtables math.parser urls combinators -furnace http http.server http.server.filters furnace.sessions -html.elements html.templates.chloe.syntax ; +html.elements html.templates.chloe.syntax db.types db.tuples +http http.server http.server.filters +furnace furnace.cache furnace.sessions ; IN: furnace.asides -TUPLE: asides < filter-responder ; +TUPLE: aside < server-state session method url post-data ; -C: asides +: