суббота, 31 октября 2009 г.

Полнотекстовый поиск: первое приближение

Нулевое приближение заключалось в изучении вопроса. Результатом стала утвердившаяся мысль о том, что мы понятия не имеем о принципах мышления и способах коммуникации между мыслящими существами. В числе прочего набрел на исследование, авторы которого утверждают, что знание хотя бы одного иностранного языка есть гарантия от маразма и прочих напастей в преклонном возрасте. Как следствие, подумал вот о чем - неумение компьютеров анализировать тексты позволяет предположить их склонность к умопомрачению. В том смысле, что полученные результаты могут быть представлены в совершенно бредовом, с человеческой точки зрения, виде. Например, недавно гуглил информацию по коробкам для розеток, и что же - на каждой странице с десятком результатов поиска была ссылка на танк! Ну, тоже коробка, конечно... в некотором роде. И даже розетки в этой "коробке" наверняка есть. Интересно следующее - собственно поиск особых сложностей не представляет, а вот ранжирование результатов доступно или в пределах некоторой узкой категории, или при очень большой выборке, причем в последнем случае результат сомнителен. Становится понятно, что от множества проектов полнотекстового поиска не стоит ожидать хоть какой-то адекватности в ранжировании, а стоит смотреть непосредственно на сам поиск. Про машинный анализ и говорить нечего - для отдельно взятых областей возможно создание экспертных методик, но при этом не исключена потеря ключевой информации.

Немного о терминологии.
stopwords - слова, которые встречаются очень часто и их необходимо игнорировать при поиске, чтобы не "засорять" результаты. Например, "это", "и", "что" и проч.
stemmer (стеммер) - алгоритм определения значащей части слова. Приведу цитату из вики:
Сте́мминг — это процесс нахождения основы слова для заданного исходного слова. Основа слова необязательно совпадает с морфологическим корнем слова. Данный процесс применяется в поиcковых системах для обобщения поискового запроса пользователя.
Конкретные реализации стемминга называются алгоритм стемминга или просто стеммер.


Как поисковый "движок" по многим причинам для меня интересен модуль FTS3 для SQLite. Ранжирование не поддерживается, но, как было указано в предисловии, это не столь важно. На его основе сделан, в частности, десктопный поисковик tracker. Последний умеет и ранжирование, что достигнуто ценой переделки всего модуля FTS3, но, пробежавшись по исходникам, не увидел использования этой возможности (везде используется значение ранга 0, а так как ранг всегда больше или равен нулю, то учитываются результаты с любым рангом). Далее, как я понимаю, tracker выполняет zlib-сжатие хранимого текста, что, несомненно, полезная функция. Заданные наборы категорий, на мой взгляд, реализованы странновато - логичнее было бы сделать группы (mime)типов с правилами их обработки, нежели чем жестко привязывать типы файлов к категориям. Скажем, потоковое видео с камер наблюдения явно не стоит включать в категорию "фильмы", да и метатэги нет смысла искать.
А теперь самое страшное - во-первых, tracker целиком "завязан" на d-bus, а во-вторых, индексатор совмещен с поисковым движком. Таким образом, получается нечто несуразное - демон, который работает в локальном сеансе пользователя. Очень жаль, что в погоне за модной свистелкой авторы tracker не додумались, что такая архитектура не позволит, к примеру, запустить индексатор на файлсервере и потом всем пользователям работать с одной индексной базой. Дублирование поискового индекса для каждого пользователя и, соответственно, "отжирание" у каждого из них немалых ресурсов на индексацию, очевидно, делают это решение неприменимым. Из интересного - судя по копирайтам Nokia в некоторых файлах исходников, проект допиливался для maemo.
Как результат, становится очевидным, что использовать будем именно FTS3. Преобразование форматов, стемминг, удаление стоп-слов должны быть внешними модулями, которые можно заменить или скомбинировать из нескольких, как вариант - ispell+snowball, russian ispell + english ispell и так далее.

Для поиска с учетом морфологии понадобится стеммер, причем написанный на чистом C и без лишних зависимостей и, разумеется, с поддержкой русского языка. Таким условиям удовлетворяет snowball, причем у него есть и отдельное описание русского стеммера. Интересен еще ispell, но в качестве дополнения, поскольку он умеет работать только со "знакомыми" словами. Когда-то я строил словарь для всех возможных комбинаций, распознаваемых ispell, получалось что-то порядка миллиона слов, так что при использовании c SQLite все их можно в табличку БД сложить и выполнять поиск нормальной формы по исходному слову.

В исходниках snowball есть утилита stemwords, которая может быть использована через пайпы:


$ echo -e "нафига\nпопу\nнаган\nесли\nпоп\nне\nхулиган"|./stemwords -p -l ru
нафига -> нафиг
попу -> поп
наган -> нага
если -> есл
поп -> поп
не -> не
хулиган -> хулига


Можно и два стеммера по очереди применить:


$ echo -e "нафига\nпопу\nнаган\nесли\nпоп\nне\nхулиган"|./stemwords -l en|./stemwords -p -l ru
нафига -> нафиг
попу -> поп
наган -> нага
если -> есл
поп -> поп
не -> не
хулиган -> хулига


Поисковый движок Xapian также использует snowball, да к тому же на сайте нашлось неплохое описание стемминга как такового Xapian: Stemming Algorithms

Также необходим словарь стоп-слов, например, Russian Stopwords (471 слово) и Free Stop Word Lists in 23 Languages. Первая ссылка, на мой взгляд, предоставляет наиболее адекватный список стоп-слов для русского языка. Проект snowball также предлагает набор стоп-слов для многих языков, так что можно выбирать на свой вкус. Для английского языка несколько списков, в т.ч. используемый MySQL FullText, представлен в статье List of English Stop Words. Не представляет сложностей сделать консольную утилиту для фильтрации стоп-слов. Вероятно, есть и уже готовая, но проще написать на свой вкус.

Кроме вышеперечисленного, не обойтись без набора фильтров для преобразования всех исходных документов в текст. Для локального поиска очень желательно уметь извлекать метатэги - для аудио и видео материалов это название композиции, автор, продолжительность, параметры сжатия и проч. Еще для локальных файлов могут быть назначены тэги средствами файловой системы. Меня локальный поиск не интересует, потому и говорить про тэги и метатэги я не буду. Фильтры можно посмотреть в tracker, где для конвертации форматов документов достаточно легковесные утилиты используются. Тем не менее, не обошлось и без "самодеятельности" - в директории ooo_converter в исходниках tracker можно найти и скомпилировать утилиту o3totxt:


gcc -o o3totxt o3totxt.c o3read.c
strip o3totxt
unzip -p test.odt content.xml | ./o3totxt > test.txt

Работает, но выдает кучу пустых строк и строк только с пробелами. Думаю, намного удобнее воспользоваться odt2txt. Кстати, мантейнер деб-пакета именно так и сделал - если заглянем в деб-патчи, увидим следующее:


-nice -n19 unzip -p "$1" content.xml | o3totxt > "$2"
+nice -n19 odt2txt "$1" > "$2"


Как видим, в общем и целом инструментарий в наличии. На офсайте snowball доступны биндинги на питоне, яве, перле, а также есть форк на C++. Где-то в глубинах интернет сгинул тиклевый биндинг. Не обошлось и без php. PostgreSQL также умеет работать со snowball, причем вот эта статья подскажет, как подготовить свой словарь и в чем разница между snowball и ispell.

Дело за малым - собрать все вместе. Над архитектурой долго раздумывать не будем, выбрав изрядно позабытый unix-way. Для отслеживания изменений возьмем inotifywait, фильтрами преобразуем в текст, удалим stopwords, вызовем консольный стеммер stemwords и полученный результат сохраним в виртуальную таблицу FTS3 в базе данных. Понятно, что при таком подходе результаты поиска будут показываться также без стоп-слов и в том виде, в каком их выдает стеммер. Получить исходный текст с выделенными результатами поиска задача более сложная, поскольку требует при индексации сохранения позиций в оригинальном тексте и тут уже не обойтись без модифицированного токенайзера. Последний выполняет потоковую обработку текста и придется заняться своей реализацией функции icuNext. Впрочем, можно сделать следующим образом - хранить еще и исходный текст после фильтра, но до преобразований, и форматировать кусок из него при отображении результатов поиска. Признаться, я сам так делать не буду, но тоже вариант. А у меня, кажется, есть идея, как это лучше сделать, причем при сохранении архитектуры.

Upd.

Совсем забыл про soundex упомянуть (в моей сборке SQLite функция доступна). С помощью этой функции можно найти слова, даже если они написаны с ошибками. Только предварительно кириллицу нужно транслитерировать. Например, поищем слово "Москва":


sqlite> select soundex('Moskva');
M210
sqlite> select soundex('Moscva');
M210
sqlite> select soundex('mascva');
M210
sqlite> select soundex('Moscvaa');
M210


Нашлись и "Москваа" и "масква".

Выберем фильтр для транслитерации. Увы, команда iconv -t ASCII//TRANSLIT заменяет кириллицу на знаки вопроса. В debian-russian мне подсказали такой способ


echo Москва | konwert UTF8-ascii
Moskva


Или можно заняться самодеятельностью, например, так:

translit.tcl

#!/usr/bin/tclsh8.5

set translit {
А A Б B В V Г G Д D Е E Ё Yo Ж Zh З Z И I Й y К K Л L М M Н N О O П P Р R С S Т T У U Ф F Х H Ц C Ч Ch Ш Sh Щ Sh Ъ "" Ы Y Ь "" Э E Ю Yu Я Ya
а a б b в v г g д d е e ё yo ж zh з z и i й y к k л l м m н n о o п p р r с s т t у u ф f х h ц c ч ch ш sh щ sh ъ "" ы y ь "" э e ю yu я ya
}

while {[eof stdin] == 0} {
puts [string map $translit [gets stdin]]
}


Upd.

Совсем забыл упомянуть про топик в рассылке, где на мои вопросы по сабжу были получены исчерпывающие ответы:
FTS statistics and stemming

четверг, 29 октября 2009 г.

SQLite и ICU

В течении достаточно продолжительного времени я использовал легковесную реализацию базового юникода для SQLite взамен апстримовской ICU-зависимой. Но некоторое время назад перешел на ICU, поскольку на современном оборудовании, к примеру, core quad, овчинка не стоит выделки. Кроме того, в дебиане наконец-то положительно решили вопрос, по которому я давно пинал мантейнера пакета sqlite:

sqlite3: Case-insensitive matching of Unicode characters does not work because ICU extension not compiled.

Теперь в debian стало возможным разрабатывать интернациональные проекты с использованием SQLite.

Возможно, еще стоит потрясти мантейнера на предмет добавления пакета с анализатором, который давно есть в моей сборке. Насчет патчей расширения функциональности надеяться не приходится - тут мантейнер сразу "посылает" в апстрим, а вот патч - решение проблемы с биндингом переменных в tcl-интерфейсе было бы полезным добавить. Что интересно, апстрим рекомендует всем заинтересованным пользователям иметь свою собственную сборку, а дебиановский мантейнер таковой поддерживать не хочет ;-)

Как следствие из вышеизложенного, в ближайшее время, полагаю, воспользуюсь полнотекстовым поиском FTS3, который после утрясания проблем с юникодом становится вполне себе удобным подручным инструментом. В свое время общение с разработчиком этого модуля привело к мысли о том, что фильтры, удаление стоп-слов и стемминг придется делать внешними средствами. Не совсем оно удобно, но, тем не менее, вполне реализуемо. Давно обещана возможность создания внешнего токенайзера, но воз и поныне там. Писать же свой модуль по моим прикидкам нецелесообразно, поскольку задачи сильно зависят от проекта, а тратить на это много времени нет возможности. Разве что напомнить апстримовскому разработчику об этом обещании, глядишь, и займется реализацией.

Что касается операционной системы, в которой живут самые обделенные в мире пользователи, то сборку libICU я выкладывал, и собрать с ней SQLite совсем нетрудно. Впрочем, я выкладывал и уже собранный SQLite+ICU, но лучше все же использовать последнюю апстримовскую версию СУБД.

Upd.

В рассылке подсказывают, что внешний токенайзер можно добавить. Сишный давно можно, а меня интересует произвольный - тиклевый или любой другой. Или я неправильно понял девелопера и эта возможность не предвидится, или я неправильно понял исходники :-)

Работа с GeoIP с помощью SQLite

Воспользуемся известной базой ip-адресов от MaxMind. Описание формата и технологии преобразования ip адреса к целому числу и обратно смотреть по ссылке.

There is popular geoip database provided by the MaxMind company.
http://www.maxmind.com/app/csv

Кроме того, можно найти уже готовую базу в формате SQLite здесь
http://alt.textdrive.com/nanoki/
На момент написания статьи актуальная база доступна по ссылке ниже.

The MaxMind dataset in SQLite database format is available by link below.
http://alt.textdrive.com/assets/public/Nanoki/IPLocation.20090201.tar.bz2

Воспользовавшись функцией ip2int() из моего расширения INET, легко получить простой запрос определения местоположения по ip-адресу.

The geolocation query can be writed easy by using the ip2int() function from my extension INET


select location.start as start,
location.end as end,
city.name as city,
region.name as region,
region.code as region_code,
country.name as country,
country.code as country_code
from location
join city on city.id = location.city_id
join region on region.id = city.region_id
join country on country.id = region.country_id
where location.start <= ip2int('195.122.250.12')
order by location.start desc
limit 1;

3279616000|3279616679|Nizhni Novgorod|Nizhegorod|51|Russian Federation|RU


Если посмотреть план выполнения запроса, мы можем увидеть, что производится индексный поиск по всем таблицам, обеспечивая высокое быстродействие.

The SQL query plan is optimal because it uses indexes by all tables.

0|0|TABLE location WITH INDEX location_start ORDER BY
1|1|TABLE city USING PRIMARY KEY
2|2|TABLE region USING PRIMARY KEY
3|3|TABLE country USING PRIMARY KEY


Как видим, задача решается быстро и элегантно. Для выполнения запроса к базе можно использовать любой удобный вам интерфейс к SQLite.

Enjoy!

среда, 28 октября 2009 г.

Конфигурация tclsh шелла .tclshrc

За конфиг спасибо Данилову Александру, который когда-то поделился им со мной. Если я правильно ошибаюсь, то исходник был найден в вики и допилен по месту. Поддерживается история команд и вызов внешних утилит. При желании можно автоматически загружать нужные пакеты расширений и проч.

.tclshrc

if {$tcl_interactive == 1} {

# set pglib_path "/usr/lib/libpgtcl1.5/libpgtcl1.5.so"
# load $pglib_path
# set sqlitelib_path "/usr/lib/sqlite3/libtclsqlite3.so.0"
# load $sqlitelib_path

lappend auto_path /usr/local/lib
puts "auto_path: $auto_path"

interp alias {} printenv {} parray env

if {$tcl_platform(platform) eq "unix"} {
proc help {command} {
exec xterm -e man -S 3tcl:3tk $command &
return
}
}
proc lspackages {{pattern *}} {
# Force the package loader to do its thing:
# NOTE: this depends on a side effect of the
# built-in [package unknown]. Other [package unknown]
# handlers might not meet our expectations.
eval [package unknown] Tcl [package provide Tcl]
foreach package [lsort [package names]] {
if {![string match $pattern $package]} { continue }
foreach version [package versions $package] {
set present [expr {
[string compare $version [package provide $package]]
? " " : "+" }]
set ifneeded \
[string replace \
[string trim \
[string map {"\n" " " "\t" " "} \
[package ifneeded $package $version]]] \
50 end "..."]
puts [format "%1s%-15s %6s %-55s" \
$present $package $version $ifneeded]
}
}
}

if {$::env(TERM) ne "dumb"} {
package require tclreadline

# uncomment the following if block, if you
# want `ls' executed after every `cd'. (This was
# the default up to 0.8 == tclreadline_version.)
#
# if {"" == [info procs cd]} {
# catch {rename ::tclreadline::Cd ""}
# rename cd ::tclreadline::Cd
# proc cd {args} {
# if {[catch {eval ::tclreadline::Cd $args} message]} {
# puts stderr "$message"
# }
# tclreadline::ls
# }
# }

# uncomment the following line to use
# tclreadline's fancy ls proc.
#
# namespace import tclreadline::ls

# tclreadline::Print is on (`yes') by default.
# This mimics the command echoing like in the
# non-readline interactive tclsh.
# If you don't like this, uncomment the following
# line.
#
# tclreadline::Print no

# uncomment the folling line, if you want
# to change tclreadline's print behaviour
# frequently with less typing.
#
# namespace import tclreadline::Print

# store maximal this much lines in the history file
#
set tclreadline::historyLength 200

# disable tclreadline's script completer
#
# ::tclreadline::readline customcompleter ""

# go to tclrealdine's main loop.
#
tclreadline::Loop
}

}

Пакет webcam

Описание можно найти и в документации, а вот свой конфиг я как-то безуспешно пытался найти. Пока снова не потерял, выкладываю.

.webcamrc

[grab]
# http://www.astro.ku.dk/~norup/webcam/readme.txt
device = /dev/video0
text = webcam %Y-%m-%d %H:%M:%S
fg_red = 255
fg_green = 255
fg_blue = 255
width = 640
height = 480
delay = 1
wait = 0
norm = pal
rotate = 0
top = 0
left = 0
bottom = -1
right = -1
quality = 75
trigger = 100
once = 0
archive = /tmp/webcam/%Y-%m-%d/%H:%M:%S.jpg

Преобразование координат

Разбираясь в своих архивах, нашел много всего почти позабытого. В том числе утилитки для преобразования координат из WGS84 в Пулково 1942 и "морских" координат. Разумеется, эти преобразования можно выполнить с помощью универсальных библиотек, но они огромны и не всегда эффективны, не говоря уж про зависимости. Так что любителям минимализма и встраиваемых решений посвящается.

#include <stdio.h>
#include <math.h>
#include <stdlib.h>

double pifact = 0.017453292519943295; // PI/180 - перевод градусов в радианы

// параметры референц-эллипсоида Красовского
double aval = 6378245.0;    // полуось эллипсоида
double f = 298.3;           // величина сжатия
// параметры системы координат 42 года (СК Пулково 42)
double cmlon = 45;          // центральный меридиан 8-й зоны
double orglat = 0;          // центральная параллель (экватор)
double scale = 1;           // масштабный коэффициент
double fe = 500000;         // восточное смещение (без номера зоны)
double fn = 0;              // северное смещение (в нашем полушарии 0)
int latNS = 1;              // полушарие (1 - северное, -1 - южное)
int lonEW = 1;              // смещение от Гринвича (1 - E, -1 - W)

int main(int argc, char *argv[])
{
  // пересчет координат GPS из геодезических в картографические
  double g = 1/f;
  double esq = 2*g-g*g;
  double epsq = esq/(1-esq);
  // координаты точки в десятичных градусах
  double inlat = 56.33847;    // широта
  double inlon = 43.98538;    // долгота

  printf("latitude = %g\n",inlat);
  printf("longitude = %g\n",inlon);

  inlat = inlat * pifact * latNS;
  orglat = orglat * pifact * latNS;
  inlon = inlon * pifact * lonEW;
  cmlon = cmlon * pifact * lonEW;
  double t = tan(inlat) * tan(inlat);//T
  //printf("T = %g\n",t);
  double c = epsq * cos(inlat) * cos(inlat);//C
  //printf("C = %g\n",c);
  double a = (inlon - cmlon) * cos(inlat);//A
  //printf("A = %g\n",a);
  double mint;
  mint = inlat * (1.-esq/4.-3*esq*esq/64.-5*esq*esq*esq/256);
  mint = mint - sin(2.*inlat)*(3*esq/8+3*esq*esq/32+45*esq*esq*esq/1024);
  mint = mint + sin(4.*inlat)*esq*esq*(15/256 + 45*esq/1024);
  double m = 1.*aval*(mint - sin(6.*inlat)*35*esq*esq*esq/3072);//M
  //printf("M = %g\n",m);
  mint = orglat * (1.-esq/4.-3*esq*esq/64.-5*esq*esq*esq/256);
  mint = mint - sin(2.*orglat)*(3*esq/8+3*esq*esq/32+45*esq*esq*esq/1024);
  mint = mint + sin(4.*orglat)*esq*esq*(15/256 + 45*esq/1024);
  double m0 = 1.*aval*(mint - sin(6.*orglat)*35*esq*esq*esq/3072);//M0
  //printf("M0 = %g\n",m0);
  double nu = 1.*aval/sqrt(1.-esq*sin(inlat)*sin(inlat));//NU
  //printf("NU = %g\n",nu);
  double easting = (5-18*t+t*t+72*c-58*epsq)*a*a/120 + (1-t+c)/6;
  easting = (1 +easting*a*a)*a*scale*nu + fe;
  double northing = a*a*(61-58*t+t*t+600*c-330*epsq)/720 + (5-t+9*c+4*c*c)/24;
  northing = (.5 + a*a*northing)*a*a*nu*tan(inlat)+m-m0;
  northing = fn + scale * northing;

  // координаты точки в СК Пулково 42, метры
  // в соответствии с правилами геодезии, приняты следующие обозначения
  // X - отсчитывается вверх от экватора (ось ординат)
  // Y - отсчитывается вправо от начального меридиана зоны (ось абсцисс)
  printf("X = %g\n",northing);
  printf("Y = %g\n",easting);

  return 0;        // завершение программы
}


#include <stdio.h>
#include <math.h>
#include <stdlib.h>

int main(int argc, char *argv[])
{
 double xpos = 4784270;
 double ypos = 7803506;

 double RadToDeg = 57.2957795132;
 double DegToRad = 0.0174532925199;
 double b = 6356752.3142;
 double PI = 3.141592654;
 double HALF_PI = 1.570796327;

 double MerToGeoLong = xpos * RadToDeg / b;
 printf("GeoLong = %f\n",MerToGeoLong);

 double MerToGeoLat = RadToDeg * (2 * atan(exp(ypos / b)) - HALF_PI);
 printf("GeoLat = %f\n",MerToGeoLat);
}

Преобразование справочника КЛАДР в формат SQLite

Статья перемещена по адресу http://sqlite.mobigroup.ru/wiki?name=sqlite3-kladr

вторник, 27 октября 2009 г.

Tcl-обертка rapi.tcl для библиотеки rapi.dll (ActiveSync)

Работает с любой версией ActiveSync, не требует компиляции и настройки. Написана несколько лет назад и с тех пор используется в продакшене. За отсутствием хидеров к библиотеке константы были найдены в дизассемблерном листинге на просторах интернет. Комментарии там тоже были - иероглифами, так что, вероятно, надо сказать "спасибо" неизвестным китайским хакерам. Переделывая знаменитые строки: "и на руинах $софта напишут наши имена". Здесь подразумеваются закрытые программные продукты, если кто не понял :-) Но, поскольку я не хакер, получив моральное удовлетворение от лицезрения вышеописанных руин, я продолжил заниматься своим делом, реализовав предлагаемую вашему вниманию библиотечку.


# Copyright 2009, Mobile Business Group
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see http://www.gnu.org/licenses/.

package require Ffidl
package provide rapi 0.1

namespace eval ::rapi {
variable rapi_rcsid {$Id: rapi.tcl,v 0.1 2007/10/06 12:00:00 mobile_business_group Exp $}
variable rapi_dll

namespace export mount umount file

set rapi_dll [file join $env(SystemRoot) system32 rapi.dll]
if { ![file exists $rapi_dll] } {
return -code error "Не установлена библиотека 'rapi.dll' Необходимо установить Microsoft ActiveSync."
}

::ffidl::callout CeRapiInitEx {pointer-byte} uint32 [::ffidl::symbol $rapi_dll CeRapiInitEx]
::ffidl::callout CeCreateDirectory {pointer-utf16 uint32} int [::ffidl::symbol $rapi_dll CeCreateDirectory]
::ffidl::callout CeRemoveDirectory {pointer-utf16} int [::ffidl::symbol $rapi_dll CeRemoveDirectory]
::ffidl::callout CeDeleteFile {pointer-utf16} int [::ffidl::symbol $rapi_dll CeDeleteFile]
::ffidl::callout CeRapiUninit {} void [::ffidl::symbol $rapi_dll CeRapiUninit]
::ffidl::callout CeGetLastError {} uint32 [::ffidl::symbol $rapi_dll CeGetLastError]
::ffidl::callout CeRapiGetError {} uint32 [::ffidl::symbol $rapi_dll CeRapiGetError]
::ffidl::callout CeCopyFile {pointer-utf16 pointer-utf16 int} uint32 [::ffidl::symbol $rapi_dll CeCopyFile]
::ffidl::callout CeCreateFile {pointer-utf16 uint32 uint32 pointer uint32 uint32 pointer} uint32 [::ffidl::symbol $rapi_dll CeCreateFile]
::ffidl::callout CeCloseHandle {uint32} int [::ffidl::symbol $rapi_dll CeCloseHandle]
::ffidl::callout CeWriteFile {uint32 pointer-byte uint32 pointer-byte pointer} int [::ffidl::symbol $rapi_dll CeWriteFile]
::ffidl::callout CeReadFile {uint32 pointer-byte uint32 pointer-byte pointer} int [::ffidl::symbol $rapi_dll CeReadFile]
::ffidl::callout CeFindFirstFile {pointer-utf16 pointer-byte} uint32 [::ffidl::symbol $rapi_dll CeFindFirstFile]
::ffidl::callout CeMoveFile {pointer-utf16 pointer-utf16} uint32 [::ffidl::symbol $rapi_dll CeMoveFile]
::ffidl::callout CeSHCreateShortcut {pointer-utf16 pointer-utf16} uint32 [::ffidl::symbol $rapi_dll CeSHCreateShortcut]
::ffidl::callout CeGetFileSize {uint32 pointer-byte} uint32 [::ffidl::symbol $rapi_dll CeGetFileSize]

proc sleep {time} {
after $time set end 1
vwait end
}

proc mount {} {
set buff [binary format i3 {12 0 0}]
set res [CeRapiInitEx $buff]
binary scan $buff i3 a
if {[lindex $a 2] != 0} {return "Не удалось инициализировать библиотеку 'rapi.dll'."}
sleep 3000
return TCL_OK
}

proc umount {} {
CeRapiUninit
}

proc file {cmd args} {
if {$cmd eq {mkdir}} {
if {[CeCreateDirectory [lindex $args 0] 0] != 0} {return TCL_OK}
return -code error "Не удалось создать каталог."
}

if {$cmd eq {rmdir}} {
if {[CeRemoveDirectory [lindex $args 0]] != 0} {return TCL_OK}
return -code error "Не удалось удалить каталог."
}

if {$cmd eq {delete}} {
if {[CeDeleteFile [lindex $args 0]] != 0} {return TCL_OK}
return -code error "Не удалось удалить файл."
}

if {$cmd eq {write}} {
# ::rapi::file write $path $data
set a {}
set c [binary format i 0]
set h [CeCreateFile [lindex $args 0] "1073741824" 2 0 2 128 0]
binary scan $h i1 a
if {$a == -1} {return -code error "Не удалось открыть файл."}
if {[CeWriteFile $h [lindex $args 1] [string length [lindex $args 1]] $c 0] == 0} {
CeCloseHandle $h
return -code error "Не удалось записать данные в файл."
}
CeCloseHandle $h
binary scan $c i1 a
return $a
}

if {$cmd eq {read}} {
# ::rapi::file read $path
set a {}
set filesize [binary format i 0]
set c [binary format i 0]
set d [binary format i 0]
set data {}

set h [CeCreateFile [lindex $args 0] "2147483648" 1 0 3 128 0]
binary scan $h i1 a
if {$a == -1} {return -code error "Не удалось открыть файл."}

set filesize [CeGetFileSize $h $d]
set buffer [binary format x$filesize]

set c [binary format i1 0]
if {[CeReadFile $h $buffer $filesize $c 0] == 0} {
return -code error "Не удалось целиком прочитать файл."
}

CeCloseHandle $h
return $buffer
}

if {$cmd eq {exists}} {
set buffer [binary format x1024]
if {[CeFindFirstFile [lindex $args 0] $buffer] != -1} {
return 1
} else {
return 0
}
}

if {$cmd eq {move}} {
# ::rapi::file move $from $to
if {[CeMoveFile [lindex $args 0] [lindex $args 1]] != 0} {return TCL_OK}
return -code error "Не удалось переместить файл."
}

if {$cmd eq {link}} {
# ::rapi::file link $path_shortcut $path_target
if {[CeSHCreateShortcut [lindex $args 0] [lindex $args 1]] != 0} {return TCL_OK}
return -code error "Не удалось создать ярлык."
}
}
}

Модуль ns_userkey для AOL Server

Описание модуля приведено в комментарии в коде.


# Copyright 2009, Mobile Business Group
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see http://www.gnu.org/licenses/.

package require json

# store and/or calculate limits and messages
proc ns_userkey_settings {name} {
switch -exact -- $name {
keylength {return 100}
valuelength {return 1024}
maxcount {return 1000}

messagesave {return "Настройки сохранены."}
messageflush {return "Настройки удалены."}
errornoargs {return "Ошибочный запрос."}
errorkeylength {return "Превышена длина имени параметра (ограничение [ns_userkey_settings keylength] символов)."}
errorvaluelength {return "Превышен размер значения параметра (ограничение [ns_userkey_settings valuelength] байт)."}
errormaxcount {return "Превышено количество параметров (ограничение [ns_userkey_settings maxcount] параметров для одного пользователя)."}
errorsystemunit {return "Системные настройки не могут быть изменены через веб-запрос."}
}
return -code error "Unknown parameter $name"
}

ns_backup_nsv_array_sheduler userkeys*

proc ns_userkey {action args} {
# проверить существование ключа
if {$action eq {exists}} {
if {[llength $args]!=2} {
return -code error {Call function as ns_userkey exists _unit_ _param_}
}
return [nsv_exists userkeys[ns_user id] [lindex $args 0],[lindex $args 1]]
} elseif {$action eq {names}} {
if {[llength $args]!=1} {
return -code error {Call function as ns_userkey names _unit_}
}
set names {}
foreach name [nsv_array names userkeys[ns_user id] [lindex $args 0],*] {
lappend names [string range $name [string last , $name]+1 end]
}
return $names
} elseif {$action eq {get_escape}} {
return [::json::string_escape [ns_userkey get {*}$args]]
} elseif {$action eq {get}} {
# получить значение ключа, если ключ не найден, функция вернет ключ по умолчанию или пустую строку
if {[llength $args]==2} {
set default {}
} else {
return -code error {Call function as ns_userkey get _unit_ _param_}
}
# если ключ не существует, нужно вернуть ключ по умолчанию
if {[nsv_exists userkeys[ns_user id] [lindex $args 0],[lindex $args 1]] == 0} {
# ключ не найден, возвращаем значение ключа по умолчанию, если таковой существует
if {[ns_defaultkey exists [lindex $args 0] [lindex $args 1]]==1} {
return [ns_defaultkey get [lindex $args 0] [lindex $args 1]]
}
# ключ по умолчанию тоже не найден, возвращаем пустую строку
return
}
return [nsv_get userkeys[ns_user id] [lindex $args 0],[lindex $args 1]]
} elseif {$action eq {set}} {
# store this data
if {[llength $args]!=3} {
return -code error {Call function as ns_userkey set _unit_ _param_ _value_}
}
if {[nsv_array size userkeys[ns_user id]] > [ns_userkey_settings maxcount]} {
return -code error [ns_userkey_settings errormaxcount]
}
nsv_set userkeys[ns_user id] [lindex $args 0],[lindex $args 1] [lindex $args 2]
return [lindex $args 2]
} elseif {$action eq {add}} {
# store this data, but only if the server *doesn't* already hold data for this key
if {[llength $args]!=3} {
return -code error {Call function as ns_userkey add _unit_ _param_ _value_}
}
if {[nsv_exists userkeys[ns_user id] [lindex $args 0],[lindex $args 1]] == 0} {
# ключ не найден
nsv_set userkeys[ns_user id] [lindex $args 0],[lindex $args 1] [lindex $args 2]
return [lindex $args 2]
}
return
} elseif {$action eq {replace}} {
# store this data, but only if the server *does* already hold data for this key
if {[llength $args]!=3} {
return -code error {Call function as ns_userkey replace _unit_ _param_ _value_}
}
if {[nsv_exists userkeys[ns_user id] [lindex $args 0],[lindex $args 1]] == 0} {
# ключ не найден
return
}
nsv_set userkeys[ns_user id] [lindex $args 0],[lindex $args 1] [lindex $args 2]
return [lindex $args 2]
} elseif {$action eq {flush}} {
# удалить ключ или набор ключей, можно использовать шаблон имени ключа
if {[llength $args]==1} {
# удалить все ключи узла
foreach key [nsv_array names userkeys[ns_user id] [lindex $args 0],*] {
nsv_unset userkeys[ns_user id] $key
}
} elseif {[llength $args]==2} {
# удалить ключи указанного узла согласно заданной маске имени
foreach key [nsv_array names userkeys[ns_user id] [lindex $args 0],[lindex $args 1]] {
nsv_unset userkeys[ns_user id] $key
}
} else {
return -code error {Call function as ns_userkey flush _unit_ ?_pattern_?}
}
}
}

Модуль проверки прав ns_perm для AOL Server

Пример 1. В случае, когда у пользователя нет права stats, следующая строка прервет выполнение скрипта и отправит клиенту сообщение о том, что доступ запрещен (Forbidden).


ns_perm stats



Пример 2. Если у пользователя есть право stats, будет выведено сообщение Hello!. Выполнение скрипта продолжится.


ns_perm stats {
ns_html::puts Hello!
}


Пример 3. Если у пользователя есть право stats, будет выведено сообщение Hello!, а иначе - сообщение Forbidden. Выполнение скрипта продолжится. Собственно, такое "изощренное" применение требуется достаточно редко.


if {[ns_perm stats {
ns_html::puts Hello!
}] == 0} {
ns_html::puts Forbidden
}


А вот и сама реализация:


# Copyright 2009, Mobile Business Group
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see http://www.gnu.org/licenses/.

# использование args необходимо, т.к. пустое значение аргумента (тело скрипта) и его отсутствие это _разные_ ситуации
proc ns_perm {names args} {
if {[ns_userkey exists system tasks_list] == 1} {
# вытаскиваем работу с мьютексом из нижеследующего цикла для предотвращения лишних блокировок
set tasks_list [ns_userkey get system tasks_list]
} else {
puts "Variable tasks_list does not found for session id=[ns_session id]"
set tasks_list {}
}
if {$tasks_list ne {}} {
# ищем хотя бы одно из указанных в аргументе names прав в списке прав пользователя
foreach name $names {
set ix [lsearch -exact $tasks_list $name]
if {$ix >= 0} break
}
} else {
set ix -1
}
if {[llength $args]==0 && $ix < 0} {
# скрипт не указан, прав на продолжение работы нет
ns_returnforbidden
catch {uplevel 1 ns_adp_break}
return 0
} elseif {[llength $args]==0 && $ix >= 0} {
# скрипт не указан, но права на продолжение работы есть
return 1
} elseif {[llength $args]==1 && $ix < 0} {
# скрипт указан, но прав на его выполнение нет
return 0
} elseif {[llength $args]==1 && $ix >= 0} {
# скрипт указан и есть права на его выполнение
if {$args ne {}} {
# тело скрипта не пустое
uplevel 1 [lindex $args 0]
}
return 1
}
return -code error {Ошибка обработки аргументов}
}

HTTP Cookie Library for AOLserver

Реализация таит в себе одну небольшую хитрость - кукисы, отправленные в текущей HTTP-сессии, также засчитываются как полученные от клиента. Такое усовершенствование позволяет существенно упростить код, в частности, авторизации.


# HTTP Cookie Library for AOLserver
# Copyright 2009, Mobile Business Group
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see http://www.gnu.org/licenses/.

proc ns_cookiegetall {} {
set jar [ns_set new]
set allcookies [ns_set get [ns_conn headers] Cookie]
if ![string equal $allcookies ""] {
foreach cookie [split $allcookies ";"] {
set pair [split $cookie "="]
ns_set put $jar [string trim [lindex $pair 0]] [lindex $pair 1]
}
}
# check unsent cookie too!
set headers [ns_conn outputheaders]
for {set i 0} {$i < [ns_set size $headers]} {incr i} {
set key [ns_set key $headers $i]
set value [ns_set value $headers $i]
if [string equal $key "Set-Cookie"] {
set cookie [lindex [split $value ";"] 0]
set pair [split $cookie "="]
ns_set update $jar [string trim [lindex $pair 0]] [lindex $pair 1]
}
}
return $jar
}

proc ns_cookieget { name } {
return [ns_urldecode [ns_set get [ns_cookiegetall] $name]]
}

proc ns_cookieset { name value path expires {domain ""} {secure ""}} {
if [string equal $name ""] {
return
}
set cookie "$name=[ns_urlencode $value]"
if ![string equal $path ""] {
append cookie "; path=$path"
}
if ![string equal $expires ""] {
append cookie "; expires=[ns_fmttime $expires "%a, %d-%b-%Y %T GMT"]"
}
if ![string equal $domain ""] {
append cookie "; domain=$domain"
} else {
append cookie "; domain=[ns_conn host]"
}
if ![string equal $secure ""] {
append cookie "; secure"
}
set headerSet [ns_conn outputheaders]
ns_set put $headerSet "Set-Cookie" $cookie
}


proc ns_cookieclean { name {domain ""} {secure ""}} {
if [string equal $name ""] {
return
}
set cookie "$name="
append cookie "; path=/"
append cookie "; expires=[ns_fmttime [expr [ns_time] - 31536000] "%a, %d-%b-%Y %T GMT"]"
if ![string equal $domain ""] {
append cookie "; domain=$domain"
} else {
append cookie "; domain=[ns_conn host]"
}
if ![string equal $secure ""] {
append cookie "; secure"
}
set headerSet [ns_conn outputheaders]
ns_set put $headerSet "Set-Cookie" $cookie
}

Кластер AOL Server с единой точкой входа под управлением HAProxy

При построении кластера с единой точкой входа возникает необходимость определенной настройки узлов кластера. Например, редирект должен отправлять пользователя не на хост, заданный в конфиг-файле AOL Server, а на тот хост, который указан в хидерах клиента. Имя точки входа и соответствующие веб-сервера определяются на уровне балансировщика, например, в HAProxy, таким образом, в конфиге AOL Server вовсе не должно быть имени точки входа; кроме того, точек входа может быть более одной.

Задача решается с помощью приведенных ниже врапперов для встроенных функций.


# Copyright 2009, Mobile Business Group
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see http://www.gnu.org/licenses/.

# создает враппер для функции редиректа, так, чтобы можно было использовать DNS алиасы
# также обеспечивает возможность работы по IP, если DNS не доступен или есть причины его не использовать
# TODO: сделать опеределение протокола, по которому работает пользователь
puts "Creating wrappers for \[ns_returnredirect url\],\[ns_info server\], \[ns_conn location\]."

# reverse-proxy must add header "X-Forwarded-Proto: https" for SSL mode
# HAProxy: reqadd X-Forwarded-Proto:\ https
# Pound: AddHeader "X-Forwarded-Proto: https"

ns_ictl oncreate {
if {[info commands _ns_returnredirect] eq {}} {
rename ns_returnredirect _ns_returnredirect
proc ns_returnredirect {url} {
if {[ns_conn port] ne {}} {
_ns_returnredirect [ns_conn protocol]://[ns_conn host]:[ns_conn port]$url
} else {
_ns_returnredirect [ns_conn protocol]://[ns_conn host]$url
}
}
}
if {[info commands _ns_conn] eq {}} {
rename ns_conn _ns_conn
proc ns_conn {args} {
if {[string match [lindex $args 0] "host"]} {
set host [string tolower [ns_set get [ns_conn headers] Host]]
set port_index [string first : $host]
if { $port_index > 0 } {
set host [string range $host 0 [expr {$port_index-1}]]
}
return $host
} elseif {[string match [lindex $args 0] "port"]} {
set host [string tolower [ns_set get [ns_conn headers] Host]]
set port_index [string first : $host]
if { $port_index > 0 } {
return [string range $host $port_index+1 end]
}
return
} elseif {[string match [lindex $args 0] "protocol"]} {
if {[string equal [ns_set get [ns_conn headers] "X-Forwarded-Proto"] "https"]} {
return https
} else {
return http
}
} elseif {[string match [lindex $args 0] "location"]} {
# is needed the host+port specification
set host [string tolower [ns_set get [ns_conn headers] Host]]
return [ns_conn protocol]://$host
} else {
return [_ns_conn {*}$args]
}
}
}
# we don't need virtual server name and replace this
if {[info commands _ns_info] eq {}} {
rename ns_info _ns_info
proc ns_info {args} {
if {[string match [lindex $args 0] "server"]} {
return [ns_config "ns/parameters" servername]
} else {
return [_ns_info {*}$args]
}
}
}
# if {[info commands _ns_info] eq {}} {
# rename ns_info _ns_info
# proc ns_info {args} {
# if {[string match [lindex $args 0] "server"]} {
# return [ns_conn host]
# } else {
# return [_ns_info {*}$args]
# }
# }
# }
}


HAProxy, помимо прочих своих талантов, умеет выполнять cookie-based балансировку. Пусть при отсутствии куки запрос отправляется на сервер-балансировщик, устанавливающий нужные куки, а при наличии требуемых куки непосредственно на целевой узел кластера. Привожу пример конфигурации с двумя целевыми узлами кластера и одним узлом балансировки.


frontend FRONTEND1
bind 127.0.0.1:80

acl site1 hdr_sub(host) site1.ru 127.0.0.1

acl backend1 hdr_sub(cookie) serverid=backend1
acl backend2 hdr_sub(cookie) serverid=backend2

use_backend site1_backend1 if site1 backend1
use_backend site1_backend2 if site1 backend2

use_backend site1_main if site1

backend site1_backend1
server backend1 127.0.0.1:1001

backend site1_backend2
server backend2 127.0.0.1:1002

backend site1_main
server main 127.0.0.1:1000


Алгоритм балансировки может быть произвольный, например, по географическому местоположению клиента.

Вывод хидеров запроса в AOL Server

Для отладки и не только бывает полезной возможность вывода хидеров, посылаемых клиентом. Для этого можно воспользоваться предложенной функцией.


ns_register_proc GET /showheaders ad_showheaders_proc
ns_register_proc POST /showheaders ad_showheaders_proc

proc ad_showheaders_proc {ignore} {
set result {}
set headers [ns_conn headers]
for {set i 0} {$i < [ns_set size $headers]} {incr i} {
set key [ns_set key $headers $i]
set value [ns_set value $headers $i]
append result "$key: $value\n"
}
ns_return 200 text/plain $result
}


Теперь достаточно обратиться по следующему адресу, например, из браузера:
http://mobigroup.ru/showheaders/

Создание файлов формата MS Excel 2003 в Tcl

В основу положена реализация, приведенная в вики wiki.tcl.tk Во-первых, выполнена "доработка напильником", во-вторых, реализован интерфейс в лисп-стиле.


# Copyright 2009, Mobile Business Group
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see http://www.gnu.org/licenses/.

#package provide excel 1.0

namespace eval ::excel:: {
variable styles
variable columnDefault
variable rowCounter
variable workbooks 0
variable workSheets
variable workbooksArray
variable workSheetsArray
variable data
variable data_str
variable style_str

namespace export book sheet row style columntype
}

proc ::excel::createWorkbook {} {
#
# @comment create a workbook pointer
# @result pointer to created workbook
#
incr ::excel::workbooks
set workbookName workbook$::excel::workbooks
set ::excel::workbooksArray($workbookName) 1
return $workbookName
}

proc ::excel::createWorkSheet {workbook name} {
#
# @comment create a worksheet pointer
# @argument workbook pointer to a workbook
# @argument name name of the worksheet
# @result pointer to a worksheet
#
variable data

if {[info exists ::excel::workbooksArray($workbook)]} {
if {![info exists ::excel::workSheets($workbook)]} {
set ::excel::workSheets($workbook) 1
} else {
incr ::excel::workSheets($workbook)
}
set workSheetName workSheet[string range ${workbook} 8 end].$::excel::workSheets($workbook)
set map_list [list \] {} \[ {} \\ {} \/ {} {*} {} {?} {} {<} {} {>} {} \{ {} \} {} {&} {} {'} {}]
set data(workSheet,$::excel::workSheets($workbook),name) [string range [string map $map_list $name] 0 29]
set data(workSheet,$::excel::workSheets($workbook)) $workSheetName
set data(workSheet,$workSheetName) 1
set ::excel::rowCounter($workSheetName) 0
return $workSheetName
} else {
error "$workbook is not a valid workbook"
}
}

proc ::excel::setColumnType {workSheet columnIndex type} {
#
# @comment define a column type
# @argument workSheet pointer to a workSheet
# @argument columnIndex index of column
# @argument type of column
# @result column type is changed
#
# variable data
# _checkSpreadSheet $workSheet
# set data($workSheet,row,$columnIndex,type) [string totitle $type]
}

proc ::excel::_checkSpreadSheet {workSheet} {
variable data
if {![info exists data(workSheet,$workSheet)]} {
error "$workSheet is not a valid workSheet"
}
}

proc ::excel::deleteWorkbook {workbook} {
#
# @comment delete a workbook pointer
# @argument workbook pointer to a workbook
# @result undecoded string
#
# variable data

unset ::excel::style_str
array unset ::excel::data_str

for {set d 1} {$d<=$::excel::workSheets($workbook)} {incr d} {
array unset ::excel::data $d
set workSheet $::excel::data(workSheet,$d)
for {set i 1} {$i<=$::excel::rowCounter($workSheet)} {incr i} {
array unset ::excel::data $workSheet*
}
unset ::excel::rowCounter($workSheet)
}

array unset ::excel::workSheetsArray
array unset ::excel::workbooksArray
array unset ::excel::rowCounter
}

proc ::excel::asXml {workbook} {
#
# @comment returns excel workbook as xml
# @argument workbook pointer to a workbook
# @result workbook xml representation
#

variable data
variable rowCounter

set xml "<?xml version='1.0' encoding='UTF-8'?>\
<?mso-application progid='Excel.Sheet'?>\
<Workbook xmlns='urn:schemas-microsoft-com:office:spreadsheet'\
xmlns:o='urn:schemas-microsoft-com:office:office'\
xmlns:x='urn:schemas-microsoft-com:office:excel'\
xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet'\
xmlns:html='http://www.w3.org/TR/REC-html40'>\
<DocumentProperties xmlns='urn:schemas-microsoft-com:office:office'>\
<Author>Mobile Business Group</Author>\
<Created>[clock format [clock seconds] -format {%Y-%m-%dT%H:%M:%SZ}]</Created>\
<Company>Mobile Business Group</Company>\
</DocumentProperties>\n\
<Styles>\n\
<Style ss:ID='s1'>\n\
<Alignment ss:Vertical='Bottom'/>\n\
<Font x:CharSet='177'/>\n\
</Style>\n"

append xml $::excel::style_str
append xml "</Styles>\n"

for {set d 1} {$d<=$::excel::workSheets($workbook)} {incr d} {
set workSheet $::excel::data(workSheet,$d)
append xml "<Worksheet ss:Name='$::excel::data(workSheet,$d,name)'>\n\
<Table x:FullColumns='1' x:FullRows='1'>\n"
append xml $::excel::data_str($workSheet)
append xml "</Table>\n</Worksheet>\n"
}
append xml "</Workbook>"

return $xml
}

proc ::excel::addRow {workSheet args} {
#
# @comment add row to excel worksheet
# @argument workSheet pointer to a workSheet
# @argument args list of variables
# @result row id
#
# variable data
# variable data_str

set xml {}
append xml "<Row>\n"
foreach arg $args {
set dataValue [string map [list & {&} < {<} > {>}] [lindex $arg 0]]
set dataType [string totitle [lindex $arg 1]]
set dataStyle [lindex $arg 2]
set dataColspan {}
if {[lindex $arg 3] ne {}} {
set dataColspan [expr {[lindex $arg 3] - 1}]
}
set dataRowspan {}
if {[lindex $arg 4] ne {}} {
set dataRowspan [expr {[lindex $arg 4] - 1}]
}
if {$dataType eq {}} {
set dataType {String}
}
if {[string index $dataValue 0] == "="} {
append xml "<Cell ss:Formula='$dataValue'"
set dataValue ""
} else {
append xml "<Cell"
}
if {$dataColspan ne {} && $dataColspan ne {-1}} {
append xml " ss:MergeAcross='$dataColspan'"
}
if {$dataRowspan ne {} && $dataRowspan ne {-1}} {
append xml " ss:MergeDown='$dataRowspan'"
}
if {$dataStyle ne {}} {
append xml " ss:StyleID='$dataStyle'>\n"
} else {
append xml ">\n"
}
append xml "<Data ss:Type='$dataType'>$dataValue</Data></Cell>\n"
}
append xml "</Row>\n"
append ::excel::data_str($workSheet) $xml

return
}


proc ::excel::createStyle {workbook args} {
#
# @comment create an excel style
# @argument workbook pointer to a workbook
# @argument args argument list
# @result style pointer
#
# variable data

set xml {}

if {[info exists ::excel::styles($workbook)]} {
incr ::excel::styles($workbook)
} else {
set ::excel::styles($workbook) 2
}
set styleName s$::excel::styles($workbook)

array set tmp $args
foreach z [array names tmp] {
if {[lsearch "-font -fontcolor -background -bold" $z]==-1} {
error "style option $z option is not supported"
}
}
foreach z [list -font -fontcolor -background -bold] {
if {[info exists tmp($z)]} {
set style$z $tmp($z)
} else {
set style$z {}
}
}

append xml "<Style ss:ID='$styleName'><Alignment ss:Vertical='Bottom'/>\n"
if {${style-font} ne {} || ${style-fontcolor} ne {}} {
append xml "<Font x:CharSet='177'"

if {${style-font} ne {}} {
append xml " ss:FontName='${style-font}'"
}

if {${style-fontcolor} ne {}} {
append xml " ss:Color='${style-fontcolor}'"
}

if {${style-bold} ne {}} {
append xml " ss:Bold='1'"
}

append xml "/>\n"
}

if {${style-background} ne {}} {
append xml "<Interior ss:Color='${style-background}' ss:Pattern='Solid'/>\n"
}

append xml "</Style>\n"

append ::excel::style_str $xml

return $styleName
}

##########################################################################
########## Функции высокого уровня, которые используются в коде ##########
proc ::excel::book { code_block } {
upvar 1 xmlbook xmlbook
uplevel 1 set xmlbook [::excel::createWorkbook]

set ::excel::style_str {}
array set ::excel::data_str {}

uplevel 1 $code_block
uplevel 1 ns_adp_mimetype "application/vnd.ms-excel"
uplevel 1 {ns_adp_puts [::excel::asXml $xmlbook]}
uplevel 1 ::excel::deleteWorkbook $xmlbook
}

proc ::excel::sheet { name code_block } {
upvar 1 xmlbook xmlbook
uplevel 1 set xmlsheet [::excel::createWorkSheet $xmlbook $name]
uplevel 1 {set ::excel::data_str($xmlsheet) {}}
uplevel 1 $code_block
}

proc ::excel::row { args } {
upvar 1 xmlsheet xmlsheet
lappend cmd ::excel::addRow $xmlsheet
append cmd " "
append cmd $args
uplevel 1 eval $cmd
}

proc ::excel::style { stylename args } {
upvar 1 xmlbook xmlbook
upvar 1 $stylename $stylename
lappend cmd ::excel::createStyle $xmlbook
append cmd " "
append cmd $args
set $stylename [eval $cmd]
}

proc ::excel::columntype { columnIndex type } {
}

Модуль ns_captionkey для AOL Server

Описание модуля приведено в комментарии в коде.


# Copyright 2009, Mobile Business Group
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see http://www.gnu.org/licenses/.

package require json

# простой интерфейс для управления заголовками
# проверки аргументов убраны, т.к. это лишний оверхед, а функции вызываются очень часто
proc ns_captionkey {action args} {
if {$action eq {exists}} {
return [nsv_exists captionkeys[lindex $args 0] [lindex $args 1]]
} elseif {$action eq {names}} {
return [nsv_array names captionkeys[lindex $args 0]]
} elseif {$action eq {get_escape}} {
return [::json::string_escape [ns_captionkey get {*}$args]]
} elseif {$action eq {get}} {
# можно указывать список юнитов, поиск ведется последовательно
if {[lindex $args 0] eq {}} {
if {[nsv_exists captionkeys[lindex $args 0] [lindex $args 1]] == 1} {
return [nsv_get captionkeys[lindex $args 0] [lindex $args 1]]
}
}
foreach name [lindex $args 0] {
if {[nsv_exists captionkeys$name [lindex $args 1]] == 1} {
return [nsv_get captionkeys$name [lindex $args 1]]
}
}
# ключ не найден, возвращаем имя ключа
return [lindex $args 1]
} elseif {$action eq {set}} {
nsv_set captionkeys[lindex $args 0] [lindex $args 1] [lindex $args 2]
return [lindex $args 2]
} elseif {$action eq {lappend}} {
# append data to list
nsv_lappend captionkeys[lindex $args 0] [lindex $args 1] [lindex $args 2]
return [nsv_get captionkeys[lindex $args 0] [lindex $args 1]]
} elseif {$action eq {aset}} {
nsv_array set captionkeys[lindex $args 0] [lindex $args 1]
} elseif {$action eq {aget}} {
return [nsv_array get captionkeys[lindex $args 0]]
}
}

Модуль ns_defaultkey для AOL Server

Описание модуля приведено в комментарии в коде.


# Copyright 2009, Mobile Business Group
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see http://www.gnu.org/licenses/.

package require json

# простой интерфейс для управления значениями по умолчанию
# проверки аргументов убраны, т.к. это лишний оверхед, а функции вызываются очень часто
# позволяет установить дефолтовые значения сразу для всех пользователей и сессий
proc ns_defaultkey {action args} {
if {$action eq {exists}} {
return [nsv_exists defaultkeys_[lindex $args 0] [lindex $args 1]]
} elseif {$action eq {names}} {
return [nsv_array names defaultkeys_[lindex $args 0]]
} elseif {$action eq {get}} {
if {[nsv_exists defaultkeys_[lindex $args 0] [lindex $args 1]] == 1} {
return [nsv_get defaultkeys_[lindex $args 0] [lindex $args 1]]
}
return
} elseif {$action eq {get_escape}} {
return [::json::string_escape [ns_defaultkey get {*}$args]]
} elseif {$action eq {set}} {
nsv_set defaultkeys_[lindex $args 0] [lindex $args 1] [lindex $args 2]
return [lindex $args 2]
} elseif {$action eq {add}} {
nsv_set defaultkeys_[lindex $args 0] [lindex $args 1] [concat [nsv_set defaultkeys_[lindex $args 0] [lindex $args 1]] [lindex $args 2]]
return [nsv_get defaultkeys_[lindex $args 0] [lindex $args 1]]
} elseif {$action eq {aset}} {
nsv_array set defaultkeys_[lindex $args 0] [lindex $args 1]
} elseif {$action eq {aget}} {
return [nsv_array get defaultkeys_[lindex $args 0]]
}
}

понедельник, 26 октября 2009 г.

Автоматическое подключение collation для русского языка в расширении ICU для SQLite

Для удобства работы с русским текстом в SQLite можно сделать автоматическое подключение нужного collation. Это позволит проводить сортировку и регистронезависимый поиск для русскоязычных текстов. В рассылке sqlite-users периодически пробегает вопрос, как же сделать такое для того или иного языка, а уж в рунете и вовсе этот вопрос "притча во языцех".

При этом сразу после открытия базы мы увидим следующее:

$ sqlite3
sqlite> pragma collation_list;
0|russian
1|NOCASE
2|RTRIM
3|BINARY


Таким образом, получаем встроенную поддержку руссого языка, достаточно лишь для поля таблицы указать "collate russian".

Для дебиана можно брать пакеты из моего репозитория. Для виндоус можно взять не сильно свежую версию SQLite с ICU
здесь (вот только не обещаю, что коллэйшен russian там автоматически грузится, поскольку сборку делал отнюдь не для русскоговорящих пользователей). Так что лучше взять последнюю версию SQLite с офсайта, пропатчить и скомпилировать с ICU, который я уже собрал и выложил тут.

Патч объявляет коллэйшен "ru_RU" как "russian" непосредственно при открытии подключения.


--- sqlite3-3.6.19.orig/ext/icu/icu.c
+++ sqlite3-3.6.19/ext/icu/icu.c
@@ -482,6 +482,19 @@
);
}

+ UErrorCode status = U_ZERO_ERROR;
+ UCollator *pUCollator = ucol_open("ru_RU", &status);
+ if( !U_SUCCESS(status) ){
+ return SQLITE_ERROR;
+ }
+
+ rc = sqlite3_create_collation_v2(db, "russian", SQLITE_UTF16, (void *)pUCollator,
+ icuCollationColl, icuCollationDel
+ );
+ if( rc!=SQLITE_OK ){
+ ucol_close(pUCollator);
+ }
+
return rc;
}

Реализация counter() для SQLIte

В заметке Счетчики в SQLite я уже упоминал про функцию counter(), позволяющую генерировать последовательные номера для возвращаемых запросом записей. В апстрим эта функция не включена и поныне, потому полагаю небесполезным привести здесь соответствующий патч. Полагаю описание функции в комментарии к коду исчерпывающим.


--- sqlite3-3.6.19.orig/src/func.c
+++ sqlite3-3.6.19/src/func.c
@@ -1397,6 +1397,35 @@
}

/*
+** Implementation of the counter(X) function. If X is an integer
+** constant, then the first invocation will return X. The second X+1.
+** and so forth. Can be used (for example) to provide a sequence number
+** in a result set.
+*/
+static void counterFunc(
+ sqlite3_context *pCtx, /* Function context */
+ int nArg, /* Number of function arguments */
+ sqlite3_value **argv /* Values for all function arguments */
+){
+ int i;
+ int *pCounter;
+
+ pCounter = (int*)sqlite3_get_auxdata(pCtx, 0);
+ if( pCounter==0 ){
+ pCounter = sqlite3_malloc( sizeof(*pCounter) );
+ if( pCounter==0 ){
+ sqlite3_result_error_nomem(pCtx);
+ return;
+ }
+ *pCounter = sqlite3_value_int(argv[0]);
+ sqlite3_set_auxdata(pCtx, 0, pCounter, sqlite3_free);
+ }else{
+ ++*pCounter;
+ }
+ sqlite3_result_int(pCtx, *pCounter);
+}
+
+/*
** All all of the FuncDef structures in the aBuiltinFunc[] array above
** to the global function hash table. This occurs at start-time (as
** a consequence of calling sqlite3_initialize()).
@@ -1476,6 +1505,7 @@
LIKEFUNC(like, 2, &likeInfoNorm, SQLITE_FUNC_LIKE),
LIKEFUNC(like, 3, &likeInfoNorm, SQLITE_FUNC_LIKE),
#endif
+ FUNCTION(counter, 1, 0, 0, counterFunc ),
};

int i;

Использование таблиц из приаттаченных баз в SQLite view

В одном из релизов была изменена логика работы с приаттаченными базами. Теперь можно создавать только временные виды, которые обращаются к таблицам из других баз. Конечно, так надежнее, но для многих систем анализа нереально копировать огромные таблицы в целевую базу, так что приходится идти на то, чтобы позволять создавать view с использованием приаттаченных баз. Разумеется, база с такими view может быть некорректна, если не приаттачены дополнительные базы. Представленный ниже патч решает вопрос в нашу пользу.


--- sqlite3-3.6.19.orig/src/attach.c
+++ sqlite3-3.6.19/src/attach.c
@@ -447,10 +447,11 @@
if( pItem->zDatabase==0 ){
pItem->zDatabase = sqlite3DbStrDup(pFix->pParse->db, zDb);
}else if( sqlite3StrICmp(pItem->zDatabase,zDb)!=0 ){
- sqlite3ErrorMsg(pFix->pParse,
+/* sqlite3ErrorMsg(pFix->pParse,
"%s %T cannot reference objects in database %s",
pFix->zType, pFix->pName, pItem->zDatabase);
- return 1;
+ return 1;*/
+ return 0;
}
#if !defined(SQLITE_OMIT_VIEW) || !defined(SQLITE_OMIT_TRIGGER)
if( sqlite3FixSelect(pFix, pItem->pSelect) ) return 1;

Две цифры номера года в SQLite функции strftime

При импорте данных из внешних источников часто встречается номер года из двух цифр, но встроенной поддержки в функции strftime для этого случая не предусмотрено. Впрочем, несложно и добавить. Патч приведен ниже, а также его можно взять из сырцового деб-пакета моей сборки SQLite.


--- sqlite3-3.6.19.orig/src/date.c
+++ sqlite3-3.6.19/src/date.c
@@ -844,6 +844,7 @@
** %w day of week 0-6 sunday==0
** %W week of year 00-53
** %Y year 0000-9999
+** %y year 00-99
** %% %
*/
static void strftimeFunc(
@@ -883,6 +884,9 @@
case 'Y':
n += 8;
break;
+ case 'y':
+ n += 4;
+ break;
case 's':
case 'J':
n += 50;
@@ -968,6 +972,10 @@
sqlite3_snprintf(5,&z[j],"%04d",x.Y); j+=sqlite3Strlen30(&z[j]);
break;
}
+ case 'y': {
+ sqlite3_snprintf(3,&z[j],"%02d",x.Y % 100); j+=sqlite3Strlen30(&z[j]);
+ break;
+ }
default: z[j++] = '%'; break;
}
}

Релиз SQLite 3.6.19

Знаменательное событие, но я как-то совсем позабыл о нем рассказать. Анонс здесь:
SQLite Release 3.6.19 On 2009 Oct 14 (3.6.19)

Как обычно, множество багфиксов и улучшений, но самое главное - добавлена поддержка foreign key constraints.

Проблема с биндингом переменных, к сожалению, осталась, так что патч все еще нужен. Пришлось его подправить, поскольку код интерфейса tclsqlite существенно изменился. Заявлена поддержка Non-Recursive Engine (NRE) для TCL 8.6 и выше.


--- sqlite3-3.6.19.orig/src/tclsqlite.c
+++ sqlite3-3.6.19/src/tclsqlite.c
@@ -757,6 +757,8 @@
Tcl_Obj *pVar = Tcl_GetObjResult(p->interp);
int n;
u8 *data;
+ Tcl_WideInt v;
+ double r;
const char *zType = (pVar->typePtr ? pVar->typePtr->name : "");
char c = zType[0];
if( c=='b' && strcmp(zType,"bytearray")==0 && pVar->bytes==0 ){
@@ -764,18 +766,10 @@
** has no string representation. */
data = Tcl_GetByteArrayFromObj(pVar, &n);
sqlite3_result_blob(context, data, n, SQLITE_TRANSIENT);
- }else if( c=='b' && strcmp(zType,"boolean")==0 ){
- Tcl_GetIntFromObj(0, pVar, &n);
- sqlite3_result_int(context, n);
- }else if( c=='d' && strcmp(zType,"double")==0 ){
- double r;
- Tcl_GetDoubleFromObj(0, pVar, &r);
- sqlite3_result_double(context, r);
- }else if( (c=='w' && strcmp(zType,"wideInt")==0) ||
- (c=='i' && strcmp(zType,"int")==0) ){
- Tcl_WideInt v;
- Tcl_GetWideIntFromObj(0, pVar, &v);
+ }else if( TCL_OK == Tcl_GetWideIntFromObj(0, pVar, &v)){
sqlite3_result_int64(context, v);
+ }else if( TCL_OK == Tcl_GetDoubleFromObj(0, pVar, &r)){
+ sqlite3_result_double(context, r);
}else{
data = (unsigned char *)Tcl_GetStringFromObj(pVar, &n);
sqlite3_result_text(context, (char *)data, n, SQLITE_TRANSIENT);
@@ -1014,6 +1008,9 @@

*ppPreStmt = 0;

+ Tcl_ObjType *tclWideIntType = Tcl_GetObjType("wideint");
+ Tcl_ObjType *tclDoubleType = Tcl_GetObjType("double");
+
/* Trim spaces from the start of zSql and calculate the remaining length. */
while( isspace(zSql[0]) ){ zSql++; }
nSql = strlen30(zSql);
@@ -1092,6 +1089,8 @@
if( pVar ){
int n;
u8 *data;
+ Tcl_WideInt v;
+ double r;
const char *zType = (pVar->typePtr ? pVar->typePtr->name : "");
char c = zType[0];
if( zVar[0]=='@' ||
@@ -1103,18 +1102,10 @@
sqlite3_bind_blob(pStmt, i, data, n, SQLITE_STATIC);
Tcl_IncrRefCount(pVar);
pPreStmt->apParm[iParm++] = pVar;
- }else if( c=='b' && strcmp(zType,"boolean")==0 ){
- Tcl_GetIntFromObj(interp, pVar, &n);
- sqlite3_bind_int(pStmt, i, n);
- }else if( c=='d' && strcmp(zType,"double")==0 ){
- double r;
- Tcl_GetDoubleFromObj(interp, pVar, &r);
- sqlite3_bind_double(pStmt, i, r);
- }else if( (c=='w' && strcmp(zType,"wideInt")==0) ||
- (c=='i' && strcmp(zType,"int")==0) ){
- Tcl_WideInt v;
- Tcl_GetWideIntFromObj(interp, pVar, &v);
+ }else if( TCL_OK == Tcl_GetWideIntFromObj(interp, pVar, &v)) {
sqlite3_bind_int64(pStmt, i, v);
+ }else if( TCL_OK == Tcl_GetDoubleFromObj(interp, pVar, &r)) {
+ sqlite3_bind_double(pStmt, i, r);
}else{
data = (unsigned char *)Tcl_GetStringFromObj(pVar, &n);
sqlite3_bind_text(pStmt, i, (char *)data, n, SQLITE_STATIC);

четверг, 22 октября 2009 г.

Менеджер очереди для микроконтроллеров

Возникло желание упростить себе написание программ для микроконтроллеров, в частности atmega8. Прежде чем заняться изобретением собственного велосипеда, я нашел и осмотрел несколько уже представленных в интернет реализаций менеджера очереди. Как обычно, все оказалось довольно печально - авторы усиленно втискивают менеджер очереди в прерывания. "И втискивал, и всовывал, и плотно утрамбовывал." (с). Самые продвинутые даже понимают, какие проблемы они себе этим создают и начинают с ними бороться путем создания мьютексов и прочих костылей. Ну, ладно, пусть их себе борются, мне-то что. Понятно, что в итоге было решено потратить часок времени на свою собственную реализацию, которая не будет отличаться неестественным интеллектом.

Рассмотрим свои потребности.

Динамическое выделение памяти менеджером очереди совершенно не оправдано, поскольку существующие процедуры известны на момент компиляции. Вполне хватит инициализированного при объявлении массива. Очередность запуска процедур пусть определяется их порядком в массиве или временем запуска, если оно указано.

При запуске контроллера нужно разово и в определенном порядке выполнить набор процедур, желательно с фиксированными задержками между ними. Отработала одна процедура, сколько требуется подождали, выполнили следующую. Все просто.

Во время работы задачи периодически повторяются. Их можно разделить на два класса - повторяемых с точно заданным интервалом и повторяемые в нужной последовательности. Как пример, отображение данных на дисплее требует точного соблюдения интервалов между запусками, что вполне себе разумно делать в таймере. Опрос клавиатуры особенной точности не требует, можно в таймере, а можно и без него. Если есть лишний таймер, пусть потрудится. А вот остальное, как-то опрос сенсоров, управление исполнительными устройствами и проч. особой точности зачастую не требуют, зато требуют фиксированного порядка запуска. Скажем, получение температуры с далласовского датчика DS18B20 это миллисекунда-другая на отправку команды датчику, ожидание 750 мс (для точности 12 бит) и снова примерно миллисекунда на получение результата. После этого надо проверить состояние исполнительного устройства. Но торопиться сильно некуда, достаточно сделать это за те же пару миллисекунд.

Для задач, подобных сканированию клавиатуры, будет полезной возможность в течении каждого просмотра очереди запускать многократно соответствующую функцию с равным интервалом между запусками.

Таким образом, нам достаточно вот такой реализации c менеджером очереди в главном цикле:
typedef unsigned char (*fptr)();
typedef struct {
 fptr func;
 unsigned char state;
 unsigned int delay;
} queue_type;

// очередь задач
queue_type g_queue[]={
 // функции инициализации, выполняются единожды при запуске
 {init_usart,0,0},
 {init_timers,0,0},
 {init_ports,0,0},
 {init_interrupts,0,0},
 {selftest,0,500},
 {beeper,0,0},
 // рабочие функции, выполняются циклически
 {sensor_conv,1,0},
 {sensor_get,1,750},
 {out,1,0}
};

main()
{
 unsigned char i,queue_size;
 int queue_delay=0, iqueue;

 // размер всей очереди
 queue_size = sizeof(g_queue)/sizeof(queue_type);

 // разовые задания, выполняются единожды при запуске с указанной задержкой после каждого задания
 for (i=0;i<queue_size;i++) {
  if (0 == g_queue[i].state) {
   g_queue[i].func();
   delay_ms(g_queue[i].delay);
  }
 }

 // время выполнения всей очереди, исключая разовые и периодические задания
 for (i=0;i<queue_size;i++) {
  if (1 == g_queue[i].state) queue_delay+=g_queue[i].delay;
 }
 // регулярные задания, выполняются в указанный момент времени или периодически кратно заданному интервалу
 while(1) {
  for(iqueue=0;iqueue <= queue_delay; iqueue++) {
  for (i=0;i<queue_size;i++) {
   if ((1==g_queue[i].state && g_queue[i].delay == iqueue) || 
    (2==g_queue[i].state && iqueue % g_queue[i].delay == 0)) {
    g_queue[i].func();
   }
  }
  delay_ms(1);
  }
 }
}


Вот, в принципе, и все. Теперь мы видим все действия и их порядок, за исключением спрятанных в таймерах, которых немного и короткие они, поскольку в таймерах критично время выполнения кода. state=0 указывает разовые процедуры инициализации, state=1 - выполняемые один раз в каждом рабочем цикле, state=2 - выполняемые периодически в каждом рабочем цикле. Можно предусмотреть временную блокировку задач, используя разные значения state. Но у меня есть сомнения, что это удобнее, чем использование глобальных флагов. А уж по эффективности так и точно хуже.

Представленный выше код можно упростить или усложнить на ваш вкус. Поставленные задачи он решает, что от него, собственно, и требовалось.

суббота, 10 октября 2009 г.

Телефонный биллинг: тариф "Направление посекундно"

Публикация имеет двоякий смысл - привести пример задачи, которую удобно выполнять именно на Tcl, а также обеспечить легкий доступ к этой информации для всех разработчиков и пользователей.

Система MBG Billing позволяет администратору системы определять собственные скрипты тарификации, причем они могут хранить правила тарификации непосредственно в своем коде или вызывать любые функции системы, в том числе для обращения к БД.

При старте веб-сервера AOL Web Server загружаются все скрипты тарифов, расположенные в определенной директории. Таким образом, для добавления нового скрипта достаточно положить его в поддиректорию tcl/telephony и перезапустить веб-сервер следующей командой
sudo sv restart billing

Здесь предполагается, что сервис имеет имя billing и управляется супервизором runit.
После этого в веб-интерфейсе можно будет назначать вновь добавленный тариф и устанавливать его параметры.

Скрипт биллингования также грузит все скрипты тарифов из вышеназванной директории. При следующем запуске по расписанию будет обнаружен новый скрипт тарифа и он сможет быть использован при обработке трафика для соответствующих услуг.

Функции скрипта тарифа фиксированы, обеспечивая единый интерфейс вызова любого тарифа. Тариф предоставляет список своих аргументов (args) и их понятное человеку название (argname) и расширенное описание (argdesc), обеспечивает проверку введенных значений аргументов (check) и биллингование (rating) записи с информацией о траффике (звонке). Для аргументов скрипта,требующих выбора значения из списка, функция vals предоставляет набор возможных значений. Внутренние переменные созданы исключительно для удобства программирования и могут быть переименованы или удалены.



############################################
# Copyright 2009, Mobile Business Group
############################################

namespace eval ::telephony::direction_second {
namespace export *

variable type {telephony}
variable name {Направление посекундно}
variable desc {Тарификация посекундная}
variable balance passive

# массив параметров тарифа, значение является списком пар название - описание параметра
# в атрибутах тарифа задается название параметра, например, "Первый тестовый параметр"
variable args {
group_name {
{Направление} {Наименование направления, например, "mtt"}
}
rcode {
{Код типа связи (опционально)} {Один из кодов R40, R1, R2 (зоновая, МГ, МН связь), R1R2 (МНМГ)}
}
}

proc type {} {
variable type
return $type
}
# финансовый счет
proc balance {} {
variable balance
return $balance
}

# идентификатор тарифа, используется как ключ БД
proc id {} {
return [namespace tail [namespace current]]
}

# название тарифа
proc name {} {
variable name
return $name
}
# описание тарифа
proc desc {} {
variable desc
return $desc
}

# список аргументов
proc args {} {
variable args
set arglist {}
foreach {name info} $args {
lappend arglist $name
}
return $arglist
}

# название аргумента
proc argname {arg} {
variable args
array set args_array $args
return [lindex $args_array($arg) 0]
}

# описание аргумента
proc argdesc {arg} {
variable args
array set args_array $args
return [lindex $args_array($arg) 1]
}
# проверка значений аргументов
# проверить значения аргумента
# вернуть пустое значение или описание ошибки
# 1-й аргумент это массив параметров биллингования
proc check {_params} {
variable args
array set args_array $args
array set params $_params
# проверить корректность указания направлений
set groups [::telephony::direction_names]
foreach arg {group_name} {
if {[info exists params($arg)]==0} {
return -code error "Не указан атрибут \"[lindex $args_array($arg) 0]\""
}
if {[lin $groups $params($arg)]==0} {
return -code error "Группа направлений $params($arg) не найдена. Допустимые значения: $groups"
}
}
# проверить код связи (необязательный аргумент)
set arg rcode
if {[info exists params($arg)]==1 && $params($arg) ne {} && [lin {R40 R1 R2 R1R2} $params($arg)]==0} {
return -code error "Код направления $params($arg) не найден. Допустимые значения: R40, R1, R2, R1R2"
}
return
}

# биллинговать запись о звонке
# 1-й аргумент это массив параметров биллингования
# 2-й аргумент это запись о звонке, переданная в виде массива (
# необходимо и достаточно указать 3 параметра, как пример:.
# duration 100 dst 78314604812 date_start "2009-01-11 15:00:01
proc rating {user_service_id _fields counter_month} {
array set fields $_fields
if {$fields(origin) ne {answer}} return
array set params [::billing::user_service::tariff_attributes $user_service_id]

set group $params(group_name)

# по известному направлению и номеру можно определить стоимость минуты разговора
array set out [::telephony:::search_direction $group $fields(dst) $fields(date_start)]
# направление найдено, но звонок по этому направлению не является платным МНМГ вызовом
# и его следует игнорировать
if {[array size out]==0} {
return
}

# если указан код, то тарифицировать только его, а иначе игнорировать
if {[info exists params(rcode)]==0 || $params(rcode) eq {}} {
# код не указан, так что тарифицировать все направления
} elseif {$params(rcode) eq $out(rcode) ||
($params(rcode) eq {R1R2} && ($out(rcode) eq {R1} || $out(rcode) eq {R2}))} {
# звонок по направлению с указанным кодом, тарифицировать
} else {
# код указан, но направление звонка имеет другой код, не тарифицируется
return
}

# тарифицируемая продолжительность
set out(duration) [[namespace current]::duration $fields(duration)]
# стоимость разговора как произведение тарифицируемой продолжительности
# на стоимость минуты по данному направлению
set out(cost) [expr {1.*$out(duration)*$out(price)/60}]
return [array get out]
}

# возвращает длительность звонка согласно правилам тарификации
# продолжительность указывается в секундах
proc duration {duration} {
# посекундная тарификация
return [::telephony::duration_second $duration]
}
}


Функция тарификации rating принимает следующие параметры - идентификатор услуги пользователя, для которой тарифицируется траффик (user_service_id), запись о траффике в виде массива (_fields) и счетчик потребления траффика по услуге за текущий месяц (counter_month). В приведенном выше тарифе счетчик не используется, т.к. стоимость МНМГ звонка не зависит от объема потребления траффика за период. Зато для местных вызовов этот счетчик зачастую необходим, когда за фиксированную абонентскую плату пользователю предоставляется определенное число минут, а по превышении разговоры тарифицируются поминутно.

Подготовка sql-запроса для SQLite в tcl

При создании видов биндинг переменных невозможен, потому приходится генерировать sql-строку с уже подставленными значениями переменных. Для того, чтобы это сделать безопасно, SQLite предоставляет функцию quote(). При использовании несуществующих переменных приведенная ниже функция ::dataset::prepare выдаст ошибку, в то время как стандартный механизм биндинга переменных в таком случае подставляет значение NULL.

Пример использования:

package require sqlite3
sqlite3 db :memory:
set i 1
set j a1
array set info {1 a b 2}
puts [::dataset::prepare db {create view view_test as select $i union select $j union select $info(1) union select $info(b)} i j info]
create view view_test as select 1 union select 'a1' union select 'a' union select 2


Реализация:

proc ::dataset::prepare {handler sql args} {
foreach arg $args {
upvar 0 $arg name
if {[uplevel 1 [list array exists $arg]]} {
foreach {key val} [uplevel 1 [list array get $arg]] {
set name($key) [$handler onecolumn {select quote($val)}]
}
} else {
set name [uplevel 1 [list set $arg]]
set name [$handler onecolumn {select quote($name)}]
}
}
return [subst -nobackslashes -nocommands $sql]
}


P.S. Порядок следования имен переменных в аргументах функции ::dataset::prepare значения не имеет.

пятница, 9 октября 2009 г.

Решение проблемы с типизацией переменных при биндинге в Tclsqlite

Выполняем скрипт с нижеприведенным кодом:
$ cat /tmp/test
package require sqlite3
sqlite3 db :memory:

db eval {create table test(a int);insert into test values (1);}
proc test {label sql result} {
global i j
puts -nonewline $label\t
set _result [db eval $sql]
if { $_result eq $result} {
puts OK
} else {
puts ERROR\t$result!=$_result
}
}
set i 1

test 1.0 {select typeof($i)} integer ;# it doesn't work in orig sqlite
test 1.1 {select * from test where a=$i} 1
test 1.2 {select * from test where 1=$i} 1 ;# it doesn't work in orig sqlite
test 1.3 {select a from test where a IN (cast($i AS INT), 160)} 1
test 1.4 {select a from test where 1 IN (cast($i AS INT), 160)} 1


$ tclsh8.5 /tmp/test
1.0 ERROR integer!=text
1.1 OK
1.2 ERROR 1!=
1.3 OK
1.4 OK


А теперь тот же самый код запускаем в tclsh8.5 шелле:
$ tclsh8.5
% package require sqlite3
sqlite3 db :memory:

db eval {create table test(a int);insert into test values (1);}
proc test {label sql result} {
global i j
puts -nonewline $label\t
set _result [db eval $sql]
if { $_result eq $result} {
puts OK
} else {
puts ERROR\t$result!=$_result
}
}
set i 1

test 1.0 {select typeof($i)} integer ;# it doesn't work in orig sqlite
test 1.1 {select * from test where a=$i} 1
test 1.2 {select * from test where 1=$i} 1 ;# it doesn't work in orig sqlite
test 1.3 {select a from test where a IN (cast($i AS INT), 160)} 1
test 1.4 {select a from test where 1 IN (cast($i AS INT), 160)} 1

3.6.18
% % % % % % % 1
% 1
% % 1.0 OK
% 1.1 OK
% 1.2 OK
% 1.3 OK
% 1.4 OK
% %


Результат выполнения, как видим, отличается. Это не единственный баг, возникающий из-за некорректного биндинга тиклевых переменных, еще есть баг с проверкой типа вставляемых данных в констрэйнтах на таблицу, а также баг с некорректным типом результата выполнения тиклевой функции из sql-запроса и другие. Собственно, само решение простое - сделать "честную" типизацию, проверяя, может ли переменная иметь числовое представление, вместо того, чтобы ограничиваться проверкой, имеет ли переменная уже такое представление - в тикле это отнюдь не одно и то же.

В качестве обходного маневра при работе с оригинальным sqlite можно делать следующее:


package require sqlite3
sqlite3 db :memory:

set i 1
puts [db onecolumn {select typeof($i)}]
string is wideint $i
puts [db onecolumn {select typeof($i)}]

set i 1.1
puts [db onecolumn {select typeof($i)}]
string is double $i
puts [db onecolumn {select typeof($i)}]


Результатом выполнения из скрипта будет
text
integer
text
real


А из tclsh шелла получим вот что
integer
integer
real
real


После вызова "string is wideint" переменная имеет числовое представление, если это возможно. Понятно, если мы не знаем тип переменной, то нужно приводить к double и wideint, именно в таком порядке. Получается программирование на побочных эффектах.

В апстрим я уже несколько багрепортов отправлял, пока безрезультатно. В своей сборке этот баг правлю.

--- tclsqlite.c.old     2009-09-05 00:37:43.000000000 +0400                                           
+++ tclsqlite.c 2009-10-09 02:50:39.000000000 +0400
@@ -754,26 +754,18 @@
}else{
Tcl_Obj *pVar = Tcl_GetObjResult(p->interp);
int n;
+ Tcl_WideInt v;
+ double r;
u8 *data;
- char *zType = pVar->typePtr ? pVar->typePtr->name : "";
- char c = zType[0];
- if( c=='b' && strcmp(zType,"bytearray")==0 && pVar->bytes==0 ){
+ if( pVar->typePtr && pVar->typePtr->name[0]=='b' && strcmp(pVar->typePtr->name,"bytearray")==0 && pVar->bytes==0 ){
/* Only return a BLOB type if the Tcl variable is a bytearray and
** has no string representation. */
data = Tcl_GetByteArrayFromObj(pVar, &n);
sqlite3_result_blob(context, data, n, SQLITE_TRANSIENT);
- }else if( c=='b' && strcmp(zType,"boolean")==0 ){
- Tcl_GetIntFromObj(0, pVar, &n);
- sqlite3_result_int(context, n);
- }else if( c=='d' && strcmp(zType,"double")==0 ){
- double r;
- Tcl_GetDoubleFromObj(0, pVar, &r);
- sqlite3_result_double(context, r);
- }else if( (c=='w' && strcmp(zType,"wideInt")==0) ||
- (c=='i' && strcmp(zType,"int")==0) ){
- Tcl_WideInt v;
- Tcl_GetWideIntFromObj(0, pVar, &v);
+ }else if( TCL_OK == Tcl_GetWideIntFromObj(0, pVar, &v)){
sqlite3_result_int64(context, v);
+ }else if( TCL_OK == Tcl_GetDoubleFromObj(0, pVar, &r)){
+ sqlite3_result_double(context, r);
}else{
data = (unsigned char *)Tcl_GetStringFromObj(pVar, &n);
sqlite3_result_text(context, (char *)data, n, SQLITE_TRANSIENT);
@@ -1629,6 +1621,9 @@
SqlPreparedStmt *pPreStmt; /* Pointer to a prepared statement */
int rc2;

+ Tcl_ObjType *tclWideIntType = Tcl_GetObjType("wideint");
+ Tcl_ObjType *tclDoubleType = Tcl_GetObjType("double");
+
if( choice==DB_EVAL ){
if( objc<3 || objc>5 ){
Tcl_WrongNumArgs(interp, 2, objv, "SQL ?ARRAY-NAME? ?SCRIPT?");
@@ -1728,7 +1723,7 @@
assert( pPreStmt==0 );
}

- /* Bind values to parameters that begin with $ or :
+ /* Bind values to parameters that begin with $ or : or @
*/
nVar = sqlite3_bind_parameter_count(pStmt);
nParm = 0;
@@ -1744,10 +1739,10 @@
if( pVar ){
int n;
u8 *data;
- char *zType = pVar->typePtr ? pVar->typePtr->name : "";
- char c = zType[0];
+ double r;
+ Tcl_WideInt v;
if( zVar[0]=='@' ||
- (c=='b' && strcmp(zType,"bytearray")==0 && pVar->bytes==0) ){
+ ( pVar->typePtr && pVar->typePtr->name[0]=='b' && strcmp(pVar->typePtr->name,"bytearray")==0 && pVar->bytes==0) ){
/* Load a BLOB type if the Tcl variable is a bytearray and
** it has no string representation or the host
** parameter name begins with "@". */
@@ -1755,18 +1750,10 @@
sqlite3_bind_blob(pStmt, i, data, n, SQLITE_STATIC);
Tcl_IncrRefCount(pVar);
apParm[nParm++] = pVar;
- }else if( c=='b' && strcmp(zType,"boolean")==0 ){
- Tcl_GetIntFromObj(interp, pVar, &n);
- sqlite3_bind_int(pStmt, i, n);
- }else if( c=='d' && strcmp(zType,"double")==0 ){
- double r;
- Tcl_GetDoubleFromObj(interp, pVar, &r);
- sqlite3_bind_double(pStmt, i, r);
- }else if( (c=='w' && strcmp(zType,"wideInt")==0) ||
- (c=='i' && strcmp(zType,"int")==0) ){
- Tcl_WideInt v;
- Tcl_GetWideIntFromObj(interp, pVar, &v);
+ }else if( TCL_OK == Tcl_GetWideIntFromObj(interp, pVar, &v)) {
sqlite3_bind_int64(pStmt, i, v);
+ }else if( TCL_OK == Tcl_GetDoubleFromObj(interp, pVar, &r)) {
+ sqlite3_bind_double(pStmt, i, r);
}else{
data = (unsigned char *)Tcl_GetStringFromObj(pVar, &n);
sqlite3_bind_text(pStmt, i, (char *)data, n, SQLITE_STATIC);


Upd.

Допилил патч для SQLite 3.6.19. Интерфейс новой версии tclsqlite существенно переписан, и в нем исправили некоторые ошибки, причем такие, на которые не было баг-репортов. Последнее не удивительно - в старой версии ошибки интерпретатора "местами" игнорировались, а найти то, чего нет, бывает весьма сложно. В результате потратил час, вставши на эти грабли, пока понял, что проблема в неявной завязке кода патча на баг интерфейса tclsqlite. Самое смешное, что в биндинге тиклевой функции я написал код корректно, а в биндинге переменных - нет. Ниже привожу код патча для версии 3.6.19.


--- sqlite3-3.6.19.orig/src/tclsqlite.c
+++ sqlite3-3.6.19/src/tclsqlite.c
@@ -757,6 +757,8 @@
Tcl_Obj *pVar = Tcl_GetObjResult(p->interp);
int n;
u8 *data;
+ Tcl_WideInt v;
+ double r;
const char *zType = (pVar->typePtr ? pVar->typePtr->name : "");
char c = zType[0];
if( c=='b' && strcmp(zType,"bytearray")==0 && pVar->bytes==0 ){
@@ -764,18 +766,10 @@
** has no string representation. */
data = Tcl_GetByteArrayFromObj(pVar, &n);
sqlite3_result_blob(context, data, n, SQLITE_TRANSIENT);
- }else if( c=='b' && strcmp(zType,"boolean")==0 ){
- Tcl_GetIntFromObj(0, pVar, &n);
- sqlite3_result_int(context, n);
- }else if( c=='d' && strcmp(zType,"double")==0 ){
- double r;
- Tcl_GetDoubleFromObj(0, pVar, &r);
- sqlite3_result_double(context, r);
- }else if( (c=='w' && strcmp(zType,"wideInt")==0) ||
- (c=='i' && strcmp(zType,"int")==0) ){
- Tcl_WideInt v;
- Tcl_GetWideIntFromObj(0, pVar, &v);
+ }else if( TCL_OK == Tcl_GetWideIntFromObj(0, pVar, &v)){
sqlite3_result_int64(context, v);
+ }else if( TCL_OK == Tcl_GetDoubleFromObj(0, pVar, &r)){
+ sqlite3_result_double(context, r);
}else{
data = (unsigned char *)Tcl_GetStringFromObj(pVar, &n);
sqlite3_result_text(context, (char *)data, n, SQLITE_TRANSIENT);
@@ -1092,6 +1086,8 @@
if( pVar ){
int n;
u8 *data;
+ Tcl_WideInt v;
+ double r;
const char *zType = (pVar->typePtr ? pVar->typePtr->name : "");
char c = zType[0];
if( zVar[0]=='@' ||
@@ -1103,18 +1099,10 @@
sqlite3_bind_blob(pStmt, i, data, n, SQLITE_STATIC);
Tcl_IncrRefCount(pVar);
pPreStmt->apParm[iParm++] = pVar;
- }else if( c=='b' && strcmp(zType,"boolean")==0 ){
- Tcl_GetIntFromObj(interp, pVar, &n);
- sqlite3_bind_int(pStmt, i, n);
- }else if( c=='d' && strcmp(zType,"double")==0 ){
- double r;
- Tcl_GetDoubleFromObj(interp, pVar, &r);
- sqlite3_bind_double(pStmt, i, r);
- }else if( (c=='w' && strcmp(zType,"wideInt")==0) ||
- (c=='i' && strcmp(zType,"int")==0) ){
- Tcl_WideInt v;
- Tcl_GetWideIntFromObj(interp, pVar, &v);
+ }else if( TCL_OK == Tcl_GetWideIntFromObj(0, pVar, &v) ) {
sqlite3_bind_int64(pStmt, i, v);
+ }else if( TCL_OK == Tcl_GetDoubleFromObj(0, pVar, &r) ) {
+ sqlite3_bind_double(pStmt, i, r);
}else{
data = (unsigned char *)Tcl_GetStringFromObj(pVar, &n);
sqlite3_bind_text(pStmt, i, (char *)data, n, SQLITE_STATIC);

(C) Alexey Pechnikov aka MBG, mobigroup.ru