unit uField;

interface

uses
  DB,
{$IFDEF VCL}
//  DBTables,
{$ENDIF}
  Rubies;

var
  cField, cFields: Tvalue;

function ap_iFields(real: TFields; owner: Tvalue): Tvalue;

function ap_iField(real: TField; owner: Tvalue): Tvalue;
procedure Init_Field;

procedure Field_ap_data_assign(field: TField; v: Tvalue);

implementation

uses
  SysUtils, Classes,
{$IFDEF VCL}
  Graphics,
{$ELSE}
  QGraphics,
{$ENDIF}
  uDefUtils, Pythia, uRDB, uDataSet;

function dl_Field(v: Tvalue): TField;
begin
  result := ap_data_get_struct(v);
end;

function dl_DataSet(v: Tvalue): TDataSet;
begin
  result := ap_data_get_struct(v);
end;

function Field_alloc(This: Tvalue; real: TField): Tvalue;
begin
  result := TmpAlloc(This, real);
end;

function ap_iField(real: TField; owner: Tvalue): Tvalue;
begin
  result := Qnil ; if real = nil then exit;
  result := Field_alloc(cField, real);
  ap_owner(result, owner);
end;

function ap_iField_v(var obj; owner: Tvalue): Tvalue;
begin
  result := ap_iField(TField(obj), owner)
end;

function Field_new(argc: integer; argv: Pointer; This: Tvalue): Tvalue; cdecl;
var
  real: TField;
  p: Pvalue;
  DataSet: TDataSet;
  FieldName: String;
  FieldType: TFieldType;
begin
  if argc < 3 then ap_raise(ap_eArgError, sToo_few_args);
  p := argv;
  real := nil;
  try
    DataSet := dl_DataSet(p^); inc(p);
    FieldName := dl_String(p^); inc(p);
    FieldType := TFieldType(dl_Integer(p^)); inc(p);
    case FieldType of
    ftString:     real := TStringField.Create(nil);
    ftSmallint:   real := TSmallIntField.Create(nil);
    ftInteger:    real := TIntegerField.Create(nil);
    ftWord:       real := TWordField.Create(nil);
    ftBoolean:    real := TBooleanField.Create(nil);
    ftFloat:      real := TFloatField.Create(nil);
    ftCurrency:   real := TCurrencyField.Create(nil);
    ftBCD:        real := TBCDField.Create(nil);
    ftDate:       real := TDateField.Create(nil);
    ftTime:       real := TTimeField.Create(nil);
    ftDateTime:   real := TDateTimeField.Create(nil);
    ftTimeStamp:  real := TSqlTimeStampField.Create(nil);
    ftBytes:      real := TBytesField.create(nil);
    ftVarBytes:   real := TVarBytesField.Create(nil);
    ftAutoInc:    real := TAutoIncField.Create(nil);
    ftBlob:       real := TBlobField.Create(nil);
    ftMemo:       real := TMemoField.Create(nil);
    ftGraphic:    real := TGraphicField.Create(nil);
    //ftFmtMemo:    real := TFmtMemoField.Create(nil);
    //ftParadoxOle: real := TParadoxOleField.Create(nil);
    //ftDBaseOle:   real := TDBaseOleField.Create(nil);
    //ftTypedBinary:real := TTypedBinaryField.Create(nil);
    //ftCursor:     real := TCursorField.Create(nil);
    //ftFixedChar:  real := TFixedCharField.Create(nil);
    ftWideString: real := TWideStringField.Create(nil);
    ftLargeInt:   real := TLargeIntField.Create(nil);
    ftADT:        real := TADTField.Create(nil);
    ftArray:      real := TArrayField.Create(nil);
    ftReference:  real := TReferenceField.Create(nil);
    ftDataSet:    real := TDataSetField.Create(nil);
    //ftOraBlob:    real := TOraBlobField.Create(nil);
    //ftOraClob:    real := TOraClobField.Create(nil);
    ftVariant:    real := TVariantField.Create(nil);
    ftInterface:  real := TInterfaceField.Create(nil);
    ftIDispatch:  real := TIDispatchField.Create(nil);
    ftGuid:       real := TGuidField.Create(nil);
    ftFMTBcd:     real := TFMTBcdField.Create(nil);
    else
      ap_raise(ap_eArgError, sWrong_arg_type);
    end;
   if argc > 3 then real.size := dl_Integer(p^);
   real.FieldName := FieldName;
   real.DataSet := DataSet;
  except
    on E: Exception do
      ap_raise(ap_eDatabaseError, E.message);
  end;
  result := ap_iField(real, Qnil);
  //Field_setup(result, real);
  ap_obj_call_init(result, argc, argv);
end;

function Field_assign(This, v: Tvalue): Tvalue; cdecl;
var
  source: TPersistent;
begin
  ap_data_get_object(v, TPersistent, source);
  dl_Field(This).Assign(source);
  result := This;
end;

function Field_save(This, v: Tvalue): Tvalue; cdecl;
var
  real: TField;
  stream: TStream;
begin
  real := ap_data_get_struct(This);
  if real is TBlobField then
    case RTYPE(v) of
    T_STRING:
      TBlobField(real).SaveToFile(dl_String(v));
    T_DATA:
      begin
        ap_data_get_object(v, TStream, stream);
        TBlobField(real).SaveToStream(stream);
      end;
    end;
  result := v;
end;

function Field_get_data_type(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Fixnum(Ord(dl_Field(This).DataType));
end;

function Field_to_f(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Float(dl_Field(This).AsFloat);
end;

function Field_to_i(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Fixnum(dl_Field(This).AsInteger);
end;

function Field_to_s(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_String(dl_Field(This).AsString);
end;

function Field_to_sql_value(This: Tvalue): Tvalue; cdecl;
var
  real: TField;
  S: string;
begin
  real := ap_data_get_struct(This);
  if real.IsNull then
    result := rb_str_new2('NULL')
  else begin
    S := real.AsString;
    if real.DataType = ftString then S := AnsiQuotedStr(S, '"');
    result := ap_String(S);
  end;
end;

function Field_inspect(This: Tvalue): Tvalue; cdecl;
var
  real: TField;
  klass: Tvalue;
begin
  real := ap_data_get_struct(This);

  result := rb_str_new2('#');
  rb_str_cat(result, '<', 1);

  klass := CLASS_OF(This);
  klass := rb_class_path(klass);
  rb_str_concat(result, klass);
  rb_str_cat(result, ':', 1);

  ap_str_cat(result, ' data_type=');
  ap_str_cat_int(result, Ord(real.DataType));
  try
    ap_str_cat(result, ' field_name=');
    rb_str_concat(result, ap_get_str_prop(real, 'FieldName', '"'));
    ap_str_cat(result, ' value=');
    ap_str_cat(result, real.AsString);
  except
    on E: Exception do
      ap_raise(ap_eDatabaseError, E.message);
  end;

  rb_str_cat(result, '>', 1);
end;

function Field_get_data_set(This: Tvalue): Tvalue; cdecl;
begin
  result := DataSetTmpAlloc(dl_Field(This).DataSet, This);
end;

function Field_set_calculated(This,v: Tvalue): Tvalue; cdecl;
begin
  dl_Field(This).Calculated := dl_Boolean(v);
  result := v;
end;

function Field_get_calculated(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Bool(dl_Field(This).Calculated);
end;

function ap_iFields(real: TFields; owner: Tvalue): Tvalue;
begin
  result := Qnil ; if real = nil then exit;
  result := TmpAlloc(cFields, real);
  ap_owner(result, owner);
end;

function Fields_aref(This, v: Tvalue): Tvalue; cdecl;
var
  real: TFields;
  I: Integer;
begin
  result := Qnil;
  try  //[ap-dev:0825]
  real := ap_data_get_struct(This);
  case RTYPE(v) of
  T_STRING:
    begin
      result := ap_iField(real.FindField(dl_String(v)), This);
    end;
  T_FIXNUM:
    begin
      I := FIX2INT(v);
      if (I < 0) or (real.Count <= I) 
        then result := Qnil
        else result := ap_iField(real[I], This);
    end;
  else
    ap_raise(ap_eArgError, sWrong_arg_type);
  end;
  except
    on E: Exception do
      ap_raise(ap_eDatabaseError, E.message);
  end;
end;

function Fields_get_count(This: Tvalue): Tvalue; cdecl;
var
  real: TFields;
begin
  real := ap_data_get_struct(This);
  result := INT2FIX(real.Count);
end;

function Fields_add(This, v: Tvalue): Tvalue; cdecl;
var
  real: TFields;
  Field: TField;
begin
  real := ap_data_get_struct(This);
  Field := dl_Field(v);
  real.Add(Field);
  result := This;
end;

function Field_get_date_time(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_DateTime(dl_Field(This).asDateTime);
end;

function Field_set_date_time(This,v: Tvalue): Tvalue; cdecl;
begin
  result := v;
  dl_Field(This).asDateTime := dl_DateTime(v);
end;

function Field_get_new_value(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Variant(TField(ap_data_get_struct(This)).NewValue);
end;

function Field_get_old_value(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Variant(TField(ap_data_get_struct(This)).OldValue);
end;

function Field_get_cur_value(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Variant(TField(ap_data_get_struct(This)).CurValue);
end;

function Field_get_value(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Variant(TField(ap_data_get_struct(This)).AsVariant);
end;

procedure Field_ap_data_assign(Field: TField; v: Tvalue);
var
  data: TObject;
(*
{$IFDEF VCL}
  BlobStream: TBlobStream;
{$ENDIF}
*)
begin
  try
  case RTYPE(v) of
  T_NIL:        Field.AsString  := '';
  T_STRING:     Field.AsString  := dl_String(v);
  T_FIXNUM:     Field.AsInteger := FIX2INT(v);
  T_BIGNUM:     Field.AsInteger := NUM2INT(v); //??
  T_FLOAT :     Field.AsFloat   := NUM2DBL(v);
  T_TRUE  :     Field.AsBoolean := True;
  T_FALSE :     Field.AsBoolean := False;
  T_DATA  :
    if ap_kind_of(v, ap_cDateTime) then
      Field.AsDateTime := dl_DateTime(v)
    else if Field is TBlobField then
      begin
        data := ap_data_get_struct(v);
(*
{$IFDEF VCL}
        if data is TGraphic then begin
          BlobStream := TBlobStream.Create(TBlobField(Field), bmWrite);
          try
            TIcon(data).SaveToStream(BlobStream);
          finally
            BlobStream.Free;
          end;
        end else
{$ENDIF}
*)
        if data is TPersistent then
          Field.Assign(TPersistent(data));
      end;
  else
    ap_raise(ap_eArgError, sWrong_arg_type);
  end;
  except
    on E: Exception do
      ap_raise(ap_eDatabaseError, E.message);
  end;
end;

function Field_set_value(This,v: Tvalue): Tvalue; cdecl;
begin
  Field_ap_data_assign(dl_Field(This), v);
  result := v;
end;

function Field_get_can_modify(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_bool(dl_Field(This).CanModify);
end;
(*
function Field_get_constraint_error_message(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_String(dl_Field(This).ConstraintErrorMessage);
end;

function Field_set_constraint_error_message(This, v: Tvalue): Tvalue; cdecl;
begin
  dl_Field(This).ConstraintErrorMessage := dl_String(v);
  result := v;
end;
*)
function Field_get_data_size(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Fixnum(dl_Field(This).DataSize);
end;

function Field_get_edit_mask(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_String(dl_Field(This).EditMask);
end;

function Field_set_edit_mask(This,v: Tvalue): Tvalue; cdecl;
begin
  dl_Field(This).EditMask := dl_String(v);
  result := v;
end;

function Field_get_has_constraints(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_bool(dl_Field(This).HasConstraints);
end;

function Field_get_field_no(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Fixnum(dl_Field(This).FieldNo);
end;

function Field_index_field_p(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_bool(dl_Field(This).IsIndexField);
end;

function Field_nil_p(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_bool(dl_Field(This).IsNull);
end;

function Field_get_size(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_Fixnum(dl_Field(This).Size);
end;

function Field_get_text(This: Tvalue): Tvalue; cdecl;
begin
  result := ap_String(dl_Field(This).Text);
end;

procedure Init_Field;
begin
  DefineConstSetType(mRDB, TypeInfo(TBlobStreamMode));
(*
{$IFDEF VCL}
  cBlobStream := rb_define_class_under(mRDB, 'BlobStream', ap_cStream);
  DefineSingletonMethod(cBlobStream, 'new', BlobStream_new);
{$ENDIF}
*)
  DefineConstSetType(mRDB, TypeInfo(TFieldType));
  DefineConstSetType(mRDB, TypeInfo(TFieldKind));

  RegisterClass(TField);
  RegisterClass(TSmallIntField);
  RegisterClass(TIntegerField);
  RegisterClass(TWordField);
  RegisterClass(TBooleanField);
  RegisterClass(TFloatField);
  RegisterClass(TCurrencyField);
  RegisterClass(TBCDField);
  RegisterClass(TDateField);
  RegisterClass(TTimeField);
  RegisterClass(TDateTimeField);
  RegisterClass(TBlobField);
  RegisterClass(TMemoField);
  RegisterClass(TGraphicField);
  RegisterClass(TSqlTimeStampField);
  RegisterClass(TBytesField);
  RegisterClass(TVarBytesField);
  RegisterClass(TAutoIncField);

  cField := DefinePersistentClass(mRDB, TField, ap_cPersistent, ap_iField_v);
  DefineSingletonMethod(cField, 'new', Field_new);
  rb_define_method(cField, 'assign', @Field_assign, 1);
  rb_define_method(cField, 'save', @Field_save, 1); // vcl: save_to_file, save_to_stream
  DefineAttrGet(cField, 'data_type', Field_get_data_type);
  rb_define_method(cField, 'to_f', @Field_to_f, 0); // vcl: AsFloat
  rb_define_method(cField, 'to_i', @Field_to_i, 0); // vcl: AsInteger
  rb_define_method(cField, 'to_s', @Field_to_s, 0); // vcl: AsString
  rb_define_method(cField, 'to_sql_value', @Field_to_sql_value, 0);
  rb_define_method(cField, 'inspect', @Field_inspect, 0);

  DefineAttrGet(cField, 'new_value', Field_get_new_value);
  DefineAttrGet(cField, 'old_value', Field_get_old_value);
  DefineAttrGet(cField, 'cur_value', Field_get_cur_value);
  DefineAttrGet(cField, 'data_set', Field_get_data_set);
  DefineAttrGet(cField, 'can_modify' , Field_get_can_modify);
(*
  DefineAttrGet(cField, 'constraint_error_message' , Field_get_constraint_error_message);
  DefineAttrSet(cField, 'constraint_error_message' , Field_set_constraint_error_message);
*)
  DefineAttrGet(cField, 'data_size' , Field_get_data_size);
  DefineAttrGet(cField, 'edit_mask' , Field_get_edit_mask);
  DefineAttrSet(cField, 'edit_mask' , Field_set_edit_mask);
  DefineAttrGet(cField, 'has_constraints' , Field_get_has_constraints);
  DefineAttrGet(cField, 'field_no' , Field_get_field_no);
  rb_define_method(cField, 'index_field?' , @Field_index_field_p, 0);
  rb_define_method(cField, 'nil?' , @Field_nil_p, 0);
  DefineAttrGet(cField, 'size' , Field_get_size);
  DefineAttrGet(cField, 'text' , Field_get_text);
//  DefineAttrGet(cField, 'valid_chars' , Field_get_valid_chars);
//  DefineAttrSet(cField, 'valid_chars' , Field_set_valid_chars);
  DefineAttrGet(cField, 'calculated' , Field_get_calculated);
  DefineAttrSet(cField, 'calculated' , Field_set_calculated);

  RegisterClass(TStringField);
  RegisterClass(TGraphicField);
  RegisterClass(TWideStringField);
  RegisterClass(TLargeIntField);
  RegisterClass(TADTField);
  RegisterClass(TArrayField);
  RegisterClass(TReferenceField);
  RegisterClass(TDataSetField);
  RegisterClass(TVariantField);
  RegisterClass(TInterfaceField);
  RegisterClass(TIDispatchField);
  RegisterClass(TGuidField);
  RegisterClass(TFMTBcdField);

  cFields := rb_define_class_under(mRDB, 'Fields', ap_cObject);
  rb_define_method(cFields, '[]', @Fields_aref, 1);
  DefineAttrGet(cFields, 'count', Fields_get_count);
  rb_define_method(cFields, 'add', @Fields_add, 1);

  DefineAttrGet(cField, 'date_time' , Field_get_date_time);
  DefineAttrSet(cField, 'date_time' , Field_set_date_time);
  DefineAttrGet(cField, 'value', Field_get_value);
  DefineAttrSet(cField, 'value', Field_set_value);
end;

exports
  ap_iField;

end.
